Experiments

R/calc_DD.R

@@ -8,7 +8,11 @@ calc_DD_m <- function(tm, k, a, b, t0, beta, c){
 
  DD_m[gt_k] <- a[gt_k]/(1 + exp(-(tm[gt_k] - t0[gt_k])/b[gt_k]))
 
+ # replace NA and negative values
+ DD_m[which(is.na(DD_m)|DD_m < 0)] <- 0
+
  DD_m
+
 }
 
 

R/calc_NFFD.R

@@ -11,11 +11,11 @@
 #' 
 calc_NFFD <- function(m, tm) {
 
- match_lines <- match(m, param$nffd$Month)
+ match_lines <- match(m, param$NFFD$Month)
 
- a <- param$nffd$a[match_lines]
- b <- param$nffd$b[match_lines]
- t0 <- param$nffd$T0[match_lines]
+ a <- param$NFFD$a[match_lines]
+ b <- param$NFFD$b[match_lines]
+ t0 <- param$NFFD$T0[match_lines]
 
  a/(1 + exp(-(tm - t0)/b))
 }

R/calc_PAS.R

@@ -11,10 +11,10 @@
 #' 
 calc_PAS <- function(m, tm) {
 
- match_lines <- match(m, param$pas$Month)
+ match_lines <- match(m, param$PAS$Month)
 
- b <- param$pas$b[match_lines]
- t0 <- param$pas$T0[match_lines]
+ b <- param$PAS$b[match_lines]
+ t0 <- param$PAS$T0[match_lines]
 
  1/(1 + exp(-(tm - t0)/b))
 }

R/downscale.R

@@ -0,0 +1,14 @@
+setClass("basepoints", slots = c(
+ latitude = "numeric",
+ longitude = "numeric",
+ elevation = "numeric",
+ historical = "character",
+ future = "character"))
+
+setGeneric("downscale", function(latitude, longitude, elevation, historical, future) {latitude})
+
+method.skeleton("downscale", "basepoint")
+
+setMethod("downscale", signature = c(latitude = "numeric", longitude = "numeric", 
+ elevation = "numeric", historical = "character", future = "character"), 
+ function(latitude, longitude, elevation, historical, future){latitude})

R/downscale_basepoint.R

@@ -0,0 +1,23 @@
+setMethod("downscale",
+ signature(
+ latitude = "numeric",
+ longitude = "numeric",
+ elevation = "numeric",
+ historical = "character",
+ future = "character"
+ ),
+ function (latitude, longitude, elevation, historical, future) 
+ {
+ #Validates parameters
+
+ }
+)
+
+available_historical_periods <- function() {
+
+} 
+
+available_future_models <- function() {
+ #TODO use system.file 
+ sort(unique(gsub("^[^.]+\\.([^.]+).*$", "\\1", dir("./inputs/gcmData/"))))
+}

downscale_basepoint.R

@@ -0,0 +1,7 @@
+setMethod("downscale",
+ signature(latitude = "basepoint"),
+ function (latitude, longitude, elevation, historical, future) 
+ {
+ stop("need a definition for the method here")
+ }
+)

inst/shiny/server.R

@@ -0,0 +1,143 @@
+#
+# This is the server logic of a Shiny web application. You can run the
+# application by clicking 'Run App' above.
+#
+# Find out more about building applications with Shiny here:
+#
+# https://shiny.rstudio.com/
+#
+
+library(shiny)
+library(DT)
+library(raster) 
+library(data.table)
+
+
+bc_tasmax <- raster::brick("../../../climR-data/BC/tasmax_mClimMean_PRISM_historical_19710101-20001231.nc")
+bc_tasmin <- raster::brick("../../../climR-data/BC/tasmin_mClimMean_PRISM_historical_19710101-20001231.nc")
+bc_pr <- raster::brick("../../../climR-data/BC/pr_mClimMean_PRISM_historical_19710101-20001231.nc")
+mat <- raster::brick("../../../climR-data/BC/map_1961-1990.tif")
+rat <- subset(mat, 1)
+pal <- colorNumeric(c("#0C2C84", "#41B6C4", "#FFFFCC"), values(rat),
+ na.color = "transparent")
+
+iris_dt <- as.data.table(iris)[1:12]
+iris_dt[, month := 1:12]
+# Define server logic required to draw a histogram
+shinyServer(function(input, output, session) {
+
+ downscale_monthly <- reactive({
+ xy_coords <- coord()
+ bilinear_values <- lapply(list(pr = bc_pr,
+ tasmin = bc_tasmin,
+ tasmax = bc_tasmax),
+ raster:::.bilinearValue,
+ xyCoords = xy_coords)
+ monthly_values <- lapply(bilinear_values, t)
+ monthly_values <- data.table(month = 1:12,
+ monthly_values$pr,
+ monthly_values$tasmin,
+ monthly_values$tasmax)
+ setnames(monthly_values, c("month", "pr", "tasmin", "tasmax"))
+ set(monthly_values, j = "Tavg", value = (monthly_values$tasmin + monthly_values$tasmax )/2)
+ set(monthly_values, j = "DD_below_0", value = calc_DD_below_0(monthly_values$month, tm = monthly_values$Tavg))
+ set(monthly_values, j = "DD_above_5", value = calc_DD_above_5(monthly_values$month, tm = monthly_values$Tavg, region = "West"))
+ set(monthly_values, j = "DD_below_18", value = calc_DD_below_18(monthly_values$month, tm = monthly_values$Tavg))
+ set(monthly_values, j = "DD_above_18", value = calc_DD_above_18(monthly_values$month, tm = monthly_values$Tavg, region = "The rest"))
+ set(monthly_values, j = "RH", value = calc_RH(monthly_values$tasmin, monthly_values$tasmax))
+ set(monthly_values, j = "RH", value = calc_RH(monthly_values$tasmin, monthly_values$tasmax))
+ set(monthly_values, j = "NFFD", value = calc_NFFD(1:12, tm = monthly_values$tasmin))
+ set(monthly_values, j = "PAS", value = calc_PAS(1:12, tm = monthly_values$tasmin))
+ return(monthly_values[ , lapply(.SD, function(x) round(x, 1))])
+ })
+
+ downscale_annualy <- reactive({
+ return(downscale_monthly()[ , lapply(.SD, function(x) round(mean(x),1))][ , -1])
+ })
+
+
+ output$annual_dt <- renderDT({
+ datatable(downscale_annualy(),
+ rownames = FALSE,
+ options=list(iDisplayLength=1,
+ bLengthChange=0,
+ bFilter=0,
+ bInfo=0,
+ bPaginate = 0,
+ initComplete = JS("function(settings, json) {$(this.api().table().header()).css({'background-color' : '#3c8dbc', 'color' : 'white'});}")
+ #bAutoWidth=0, # automatic column width calculation, disable if passing column width via aoColumnDefs
+ #aoColumnDefs = list(list(sWidth="300px", aTargets=c(list(0),list(1)))) # custom column size 
+ )
+ )
+ })
+
+ # output$seasonal_dt <- renderDT({
+ # datatable(iris_dt[1],
+ # rownames = FALSE,
+ # options=list(iDisplayLength=1,
+ # bLengthChange=0,
+ # bFilter=0,
+ # bInfo=0,
+ # bPaginate = 0,
+ # initComplete = JS("function(settings, json) {$(this.api().table().header()).css({'background-color' : '#3c8dbc', 'color' : 'white'});}")
+ # )
+ # )
+ # })
+
+ output$monthly_dt <- renderDT({
+ datatable(downscale_monthly(),
+ rownames = FALSE,
+ options=list(iDisplayLength=12,
+ bLengthChange=0,
+ bFilter=0,
+ bInfo=0,
+ bPaginate = 0,
+ initComplete = JS("function(settings, json) {$(this.api().table().header()).css({'background-color' : '#3c8dbc', 'color' : 'white'});}")
+ )
+ )
+ })
+
+ output$monthly_subplot <- renderPlotly({
+
+ monthly_plots <- list()
+ i <- 1
+ for (variable in names(downscale_monthly())) {
+ if (class(downscale_monthly()[[variable]]) == "numeric" & variable != "month") {
+ monthly_plots[[i]] <- plot_ly(x = downscale_monthly()[["month"]], y = downscale_monthly()[[variable]], type = 'scatter', mode = 'lines+markers', name = variable)
+ i <- i + 1
+ }
+
+ }
+ subplot(monthly_plots, nrows = 4)
+ })
+
+
+ output$map <- renderLeaflet({
+ leaflet() |> addTiles() |>
+ addRasterImage(rat, colors = pal, opacity = 0.8) |>
+ addLegend(pal = pal, values = values(rat),
+ title = "mat_1961-1990") |>
+ setView(lng = -125.222385126562, lat = 54.2914890653002, zoom = 5) |>
+ addMarkers(lng = -115.02, lat = 48.98)
+ })
+
+ map_proxy <- leafletProxy("map")
+
+ observeEvent(input$map_click, {
+ click <- input$map_click
+
+ updateNumericInput(session, "latitude", value = click$lat)
+ updateNumericInput(session, "longitude", value = click$lng)
+ })
+
+ coord <- reactive({
+ cbind(input$longitude, input$latitude)
+ })
+
+ observeEvent(coord(), {
+ map_proxy |> clearMarkers()
+ map_proxy |> addMarkers(lng = coord()[1], lat = coord()[2])
+ })
+
+
+})

inst/shiny/ui.R

@@ -0,0 +1,135 @@
+#
+# This is the user-interface definition of a Shiny web application. You can
+# run the application by clicking 'Run App' above.
+#
+# Find out more about building applications with Shiny here:
+#
+# https://shiny.rstudio.com/
+#
+
+library(shiny)
+library(shinydashboard)
+library(DT)
+library(leaflet)
+library(plotly)
+
+# Define UI for application that draws a histogram
+
+shinyUI(
+ dashboardPage(
+ dashboardHeader(title = "ClimateNA app"),
+ dashboardSidebar(
+ numericInput(inputId = "latitude", label = "Latitude", min = -90, max = 90, value = 48.98),
+ numericInput(inputId = "longitude", label = "Longitude", min = -180, max = 180, value = -115.02),
+ numericInput(inputId = "elevation", label = "Elevation (m)", min = -430, max = 8848, value = 1000),
+ selectInput(inputId = "historical", label = "Historical", choices = c("Normal_1961_1990", "Normal_1901_1930")),
+ selectInput(inputId = "future", label = "Future", choices = c("Select a GCM period", "13GCMs_ensemble_ssp126_2011-2040.gcm"))
+ ),
+ dashboardBody(
+ fluidRow(
+ column(
+ width = 7,
+ box(
+ title = "Annual Variables",
+ width = 12,
+ DTOutput(outputId = "annual_dt")
+ ),
+ br(),
+ br(),
+ br(),
+ # box(
+ # title = "Seasonal Variables",
+ # width = 12,
+ # DTOutput(outputId = "seasonal_dt")
+ # ),
+ # br(),
+ # br(),
+ # br(),
+ tabBox(
+ title = "Monthly Variables",
+ side = 'right',
+ width = 12,
+ id = "monthly_tabset",
+ tabPanel(
+ title = "Table",
+ DTOutput(outputId = "monthly_dt")
+ ),
+ tabPanel(
+ title = "Plots",
+ plotlyOutput(outputId = "monthly_subplot")
+ )
+ )
+ ),
+ column(
+ width = 5,
+ box(
+ width = 12,
+ leafletOutput(outputId = "map", height = 1080)
+ )
+ )
+ )
+ )
+ )
+)
+
+
+
+# shinyUI(fluidPage(
+# titlePanel("ClimateNA Map"),
+# sidebarLayout(
+# sidebarPanel(width = 5,
+# fluidRow(
+# column(width = 6,
+# numericInput(inputId = "latitude", label = "Latitude", min = -90, max = 90, value = 48.98)
+# ),
+# column(width = 6,
+# numericInput(inputId = "longitude", label = "Longitude", min = -180, max = 180, value = -115.02)
+# )
+# ),
+# fluidRow(
+# column(width = 6,
+# numericInput(inputId = "elevation", label = "Elevation (m)", min = -430, max = 8848, value = 1000)
+# ),
+# column(width = 6,
+# selectInput(inputId = "historical", label = "Historical", choices = c("Normal_1961_1990", "Normal_1901_1930"))
+# )
+# ),
+# fluidRow(
+# column(width = 12,
+# selectInput(inputId = "future", label = "Future", choices = c("Select a GCM period", "13GCMs_ensemble_ssp126_2011-2040.gcm"))
+# )
+# ),
+# br(),
+# fluidRow(
+# column(width = 4,
+# actionButton(inputId = "tutorial", label = "Quick Tutorial", width = "80%")
+# ),
+# column(width = 4,
+# actionButton(inputId = "help", label = "Help", width = "80%")
+# ),
+# column(width = 4,
+# actionButton(inputId = "calculate", label = "Calculate", width = "80%")
+# )
+# ),
+# br(),
+# br(),
+# br(),
+# fluidRow(
+# column(width = 12,
+# DTOutput(outputId = "result_dt")
+# )
+# ),
+# br(),
+# fluidRow(
+# column(width = 1,
+# actionButton(inputId = "save", label = "Save")
+# ),
+# column(width = 1,
+# actionButton(inputId = "clear", label = "Clear")
+# )
+# )
+# ),
+# mainPanel("main panel", width = 7,
+# plotOutput(outputId = "map", height = "940px"))
+# )
+# ))

scripts/db.r

@@ -0,0 +1,16 @@
+# sudo apt install postgresql postgis
+# sudo -u postgres psql
+# CREATE DATABASE climrpnw;
+# \q
+# sudo -u postgres psql -d climrpnw
+# CREATE USER climrpnw PASSWORD 'climrpnw'
+
+library(RPostgres)
+conn <- dbConnect(
+ drv = Postgres(),
+ dbname = "climrpnw",
+ host = "localhost",
+ port = 5432, 
+ user = "climrpnw",
+ password = "climrpnw"
+)