Chapter 4 The Fisheries SUA-FBS Shiny R code
The Shiny application used for SUA and FBS imputation and validation has several files. It contains the three standard Shiny files (global, ui and server), a file for each tab and file with external functions. The application directly connects, pulls and modifies data and other information from the Statistical Working System (SWS).
The following paragraphs contain the code as visible in the folder in the Shiny server and in the shared drive (R:/shiny-app/shinyFisheriesSUAFBS).
4.1 ‘global.R’ file
The global.R file is a list of elements that will be used several times in different part of the shiny. After listing the library path access, the needed packages and the initial token, the file contains a function replaceforeignchars to convert the the characters non-readable in the shiny.
After this introductory elements the list contains the tokens, the datasets names, the country, element, the item codes and the mapping files used in the shiny.
# packages
.libPaths( c("/usr/local/lib64/R-3.1.2/library","/work/SWS_R_Share/shiny/Rlib/3.1",.libPaths()))
#suppressMessages{(
library(data.table)
library(DT)
library(faosws)
library(faoswsFlag)
library(faoswsProcessing)
library(faoswsUtil)
library(faoswsImputation)
library(ggplot2)
library(rhandsontable)
library(shiny)
library(shinyWidgets)
#)}
source('R/recalculateFunctions.R')
source('R/ErCalcReviewed.R')
source('R/InputCalc.R')
source('R/FoodProcCalcNew.R')
source('R/reloadData.R')
# token <- as.character(input$btn_token)
localrun <- TRUE
#-- Token QA ----
if(localrun){
if(CheckDebug()){
library(faoswsModules)
SETTINGS = ReadSettings("sws.yml")
R_SWS_SHARE_PATH = SETTINGS[["share"]]
SetClientFiles(SETTINGS[["certdir"]])
GetTestEnvironment(baseUrl = SETTINGS[["server"]],
token = '0211dad4-4c6a-4f66-a2f0-f21a1edef8a2')
}
} else {
R_SWS_SHARE_PATH = "Z:"
SetClientFiles("/srv/shiny-server/.R/QA/")
GetTestEnvironment(baseUrl = "https://swsqa.aws.fao.org:8181",
token = "54992801-519f-4d80-89f4-2de4aadada87")
}
#-- Encoding ----
replaceforeignchars <- function(dat)
{
fromto <- read.table(text="
from to
š s
Å A
œ oe
ž z
ß ss
þ y
à a
á a
â a
ã a
ä a
å a
æ ae
ç c
è e
é e
ê e
ë e
ì i
í i
î i
ï i
ð d
ñ n
ò o
ó o
ô o
õ o
ö o
ø oe
ù u
ú u
û u
ü u
ý y
ÿ y
ğ g",
header=TRUE)
for(i in 1:nrow(fromto) ) {
dat <- gsub(fromto$from[i],fromto$to[i],dat)
}
dat
}
#-- Lists ----
# Tokens plugin
tokens <- ReadDatatable('fi_sua_fbs_token')
tokenSuaU <- tokens$token[1]
tokenSuaB <- tokens$token[2]
tokenFbs <- tokens$token[3]
tokenFbsFaostat <- tokens$token[4]
# Tokens validated
tokensVal <- ReadDatatable('fi_sua_fbs_token_val')
tokenSuaUval <- tokensVal$token[1]
tokenSuaBval <- tokensVal$token[2]
tokenFbsFiasval <- tokensVal$token[3]
tokenFbsFaostatval <- tokensVal$token[4]
domainGP <- 'Fisheries'
domainComm <- 'FisheriesCommodities'
datasetGP <- 'fi_global_production'
datasetCDB <- 'commodities_total'
datasetSUABfrozen <-'fi_sua_balanced_validated'
datasetFBSfrozen <- 'fi_fbs_fias_validated'
datasetSUAUlive <- 'fi_sua_unbalanced'
datasetSUABlive <-'fi_sua_balanced'
datasetFBSlive <- 'fi_fbs_fias'
datasetFBSfaostatlive <- 'fi_fbs_faostat'
datasetSUAUval <- 'fi_sua_unbalanced_validated'
datasetSUABval <-'fi_sua_balanced_validated'
datasetFBSval <- 'fi_fbs_fias_validated'
datasetFBSfaostatval <- 'fi_fbs_faostat_validated'
primaryEl <- c('5510', '5610', '5910')
NutrientsEl <- c('261', '264', '271', '274', '281', '284')
SUAel <- c('5302', '5423', '5510', '5610', '5071', '5910',
'5520', '5525', '5023', '5141', '5153', '5166')
ValueElements <- c('5922', '5930', '5622', '5630')
# Country input
M49 <- GetCodeList(domain = domainComm, dataset = datasetCDB, dimension = "geographicAreaM49_fi") #, codes = countrylist$geographicaream49_fi)
M49 <- M49[ type == "country", .( description, code)]
M49$description <- replaceforeignchars(M49$description)
country_input <- sort(sprintf("%s - %s", M49$description, as.numeric(M49$code))) # unique(commodityDB$geographicAreaM49)
country_input <- data.table(label = country_input, code = sub(" ", "", sub(".*-", "", country_input)))
country_input <- rbind(data.table(label = "", code = "-"), country_input)
# Element groups
elementGroups <- c('Single', 'All', 'Primary', 'SUA', 'Nutrients')
# Element input
allElements <- GetCodeList(domainComm, datasetFBSfrozen,"measuredElementSuaFbs")[, .(description, code)]
# FBS elements
included <- data.table(code = c('5141', '645', '5510', '5610', '5910', '5302', '5071',
'5153', '5166', '664', '674', '684', '511'))
included[ , idx := as.numeric(row.names(included))]
elements <- merge(allElements, included, by = 'code')
elements <- elements[order(elements$idx)]
element_label <- sprintf("%s - %s", elements$description, as.numeric(elements$code))
element_input <- data.table(label = element_label, code = elements$code)
# SUA elements
SUAincluded <- data.table(code = c('5302', '5423', '5510', '5610', '5622', '5630',
'5071', '5910', '5922', '5930', '5520', '5525',
'5023', '5141', '5153', '5166',
'261', '264', '271', '274', '281', '284'))
SUAincluded[ , idx := as.numeric(row.names(SUAincluded))]
SUAelements <- merge(allElements, SUAincluded, by = 'code')
SUAelements <- SUAelements[order(SUAelements$idx)]
sua_element_label <- sprintf("%s - %s", SUAelements$description, as.numeric(SUAelements$code))
sua_element_input <- data.table(label = sua_element_label, code = SUAelements$code)
# Group input
groups <- GetCodeList(domainComm, datasetFBSfrozen,"measuredItemFaostat_L2")[, .(description, code)]
groups <- groups[order(as.numeric(code)),]
groups_label <- sprintf("%s - %s", groups$description, as.numeric(groups$code))
groups_input <- data.table(label = groups_label, code = groups$code)
# Map Faostat L1 and Faostat L2 codes
l2l1 <- ReadDatatable('ics_l1_2_ics_l2')
l2l1 <- l2l1[order(as.numeric(code_l2)),]
# Map Asfis - Isscaap - Ics
map_asfis <- ReadDatatable('map_asfis')
setnames(map_asfis, c("ics", "asfis"), c("ICSProd", "fisheriesAsfis"))
# Map Isscfc - Ics
map_isscfc <- ReadDatatable('map_isscfc')
setnames(map_isscfc, c("ics","measured_item_isscfc"), c("ICSProd","measuredItemISSCFC"))
# Tab7 element not to consider
elkeyNot2consider <- c('261', '264', '271', '274', '281', '284', '511')
updated_mappings <- reactiveValues(GP = data.table(),
CDB = data.table())
# Name of file to read
filename <- ''
FPfile <<- list(primary = data.table(), secondary = data.table(),
secondaryTot = data.table(), tertiary = data.table(),
quaternary = data.table(), NotCovered = data.table())
4.2 ‘ui.R’ file
The ui.R file contains the interface structure of the Shiny app with the outputs of the server.R file. Each tabPanel functions is a tab containing different objects (buttons, graphs, table).
Few buttons are defined directly into this file as they are simple buttons.
ui = fluidPage(
title = "SUA-FBS Tools",
br(),
column(12,
column(3,
selectInput(inputId = "btn_country",
label = 'Country',
choices = country_input$label #,
# selected = 'Chile - 152'
)
),
column(1,
uiOutput('btn_year')
),
column(1,
uiOutput('btn_start_year')
),
column(3,
uiOutput('btn_element_fbs')
)
),
tabsetPanel(id = "tabs",
tabPanel("Token", fluid = TRUE,
column(12,
column(12,
br(),
h4('Insert new token.'),
h5('The tokens in the table are the last used ones.
If the session used has changed please update the tokens through the buttons below.
Otherwise, the session used will be the one linked to the token in the table displayed.'),
br()),
column(8,
DT::dataTableOutput('token_tab'),
br(),
uiOutput('btn_token1'),
br(),
uiOutput('btn_token2'),
br(),
uiOutput('btn_token3'),
br(),
uiOutput('btn_token4'),
br(),
actionBttn("btn_upd_token", label = "Update token",
color = "primary",
style = "jelly"))
)
),
tabPanel("Overview", fluid = TRUE,
column(12,
plotOutput('gg_plot_tab1', width = '80%'),
DT::dataTableOutput('fbs_fias_tab1')
)
),
tabPanel("SUA compare", fluid = TRUE,
column(12,
column(3,
uiOutput('btn_group_fbs'),
uiOutput('btn_element_group'),
uiOutput('btn_element_sua')
),
column(9,
DT::dataTableOutput('sua_comp_tab2')
)
)
),
tabPanel("SUA imbalances", fluid = TRUE,
column(12,
column(8,
h4('SUA imbalance before Production increase.'),
br(),
plotOutput('gg_plot_tab2bis', width = '80%')
),
column(4,
DT::dataTableOutput('sua_imb_tab2')
),
column(12,
h4('SUA Production values before (Unbal) and after (Bal) increase.'),
h5('Please note values after increase are those displayed and used for FBS calculations.'),
DT::dataTableOutput('sua_prod_diff_tab2')
)
)
),
tabPanel("FBS by ICS", fluid = TRUE,
column(12,
column(3,
uiOutput('btn_group_fbs_tab3'),
uiOutput('btn_ics_prod_tab3')
),
column(9,
br(),
br(),
plotOutput('gg_plot_tab3'),
DT::dataTableOutput('sua_ics_tab3')
)
)
),
tabPanel("ICS by element", fluid = TRUE,
column(12,
column(3,
uiOutput('btn_group_fbs_tab4'),
uiOutput('btn_ics_prod_tab4'),
uiOutput('btn_element_group_tab4'),
uiOutput('btn_element_sua_tab4')
),
column(9,
plotOutput('gg_plot_tab4'),
DT::dataTableOutput('sua_elem_tab4')
)
)
),
tabPanel("Global Prod", fluid = TRUE,
column(12,
column(3,
br(),
actionBttn("saveGP", label = "Save",
color = "primary",
style = "gradient"),
br(),
br(),
uiOutput('btn_group_fbs_tab5'),
rHandsontableOutput('gp_map_tab5')
),
column(9,
DT::dataTableOutput('gp_tab5')
)
)
),
tabPanel("Commodities", fluid = TRUE,
column(12,
column(3,
br(),
actionBttn("saveCDB", label = "Save",
color = "primary",
style = "gradient"),
br(),
br(),
uiOutput('btn_group_fbs_tab6'),
uiOutput('btn_ics_prod_tab6'),
uiOutput('btn_element_cdb_tab6'),
rHandsontableOutput('cdb_map_tab6')
),
column(9,
h4('Note the ICS codes in the table refer to YBKlang file amd applies to ISSCFC codes,
i.e. the ICS codes are the default ones before the application of the link table.'),
DT::dataTableOutput('cdb_tab6')
)
)
),
tabPanel("Link table", fluid = TRUE,
column(12,
br(),
br(),
column(2,
actionBttn("updLT", label = "Update table",
color = "danger",
style = "gradient")),
column(10,
rHandsontableOutput('linktable')
)
)
),
tabPanel("Balancing elements", fluid = TRUE,
column(12,
br(),
br(),
column(2,
actionBttn("updBal", label = "Update table",
color = "danger",
style = "gradient")),
column(10,
rHandsontableOutput('balancingelements')
)
)
),
tabPanel("Extraction rates", fluid = TRUE,
column(12,
br(),
br(),
column(2,
radioButtons(inputId = "radioErUpdt",
label = h4("Update type"),
choices = list("Single year" = 1,
"Selected time series" = 2 #,
#"Whole time series" = 3
),
selected = 1),
actionBttn("updER",
label = "Update",
color = "danger",
style = "gradient")),
column(10,
h4("Note this tab is to perform block or single extraction rate updates.
Update the series of each product (measuredItemFaostat_L2) only with one value when choosing 'selected series' updates."),
h5('In general, avoid to put different values for different years. Use the data validation tab for this detailed operations.'),
rHandsontableOutput('extrR')
)
)
),
tabPanel("Data validation", fluid = TRUE,
column(12,
column(4,
h5('Download SUA table'),
downloadButton('downloadData', 'Save as .csv'),
br(),
br(),
radioButtons(inputId = "csv_online",
label = "Update to consider",
inline = TRUE,
choices = list("Online modifications" = 1,
"Uploaded .csv file" = 2),
selected = 1),
h5("Please select if Input or the Extraction rate figures prevail."),
h5("If no official input is inserted choose 'Extr rate'"),
radioButtons(inputId = "radioErVSinput",
label = "Use",
inline = TRUE,
choices = list("Extr rates" = 1,
"Input" = 2,
"Null" = 3),
selected = 3),
radioButtons(inputId = "reprocess",
label = "Reprocessing type",
inline = FALSE,
choices = list("No calculations wanted" = 'No',
"Complete" = 'Complete',
"Only SUA balanced" = 'SUAb',
"Since SUA balanced" = 'SUAbTot',
"Only Nutrients & FBS" = 'NutFbs'),
selected = 'No'),
uiOutput('btn_group_fbs_tab7'),
uiOutput('btn_ics_prod_tab7'),
uiOutput('btn_element_group_tab7'),
uiOutput('btn_sua_elem_tab7')
),
column(8,
br(),
column(5,
fileInput("updatedSUA", "Upload CSV file",
multiple = FALSE,
accept = c("text/csv",
"text/comma-separated-values,text/plain",
".csv"))),
br(),
column(3,
actionBttn("save", label = "Save & Recalc",
color = "primary",
style = "gradient")),
rHandsontableOutput('sua_tab7'),
tableOutput("contents"),
br(),
textOutput('textAv'),
br(),
rHandsontableOutput('availability'),
br(),
h4("Primary availability not covering rank 1 children:"),
br(),
DT::dataTableOutput('FPtab1'),
br(),
h4("Insufficient secondary availability:"),
br(),
DT::dataTableOutput('FPinsuff'),
br(),
h4("Level by level availability problems:"),
br(),
DT::dataTableOutput('FPsecPar'),
br(),
h4("Total uncovered quantities:"),
br(),
DT::dataTableOutput('FPtabUncov')
)
)
),
tabPanel("Data update", fluid = TRUE,
column(12,
plotOutput('gg_plot_tab8', width = '80%'),
DT::dataTableOutput('fbs_fias_tab8')
)
),
tabPanel("Data saving", fluid = TRUE,
column(12,
column(4,
br(),
actionBttn("btn_upd_token_val", label = "Update token",
color = "primary",
style = "jelly"),
br(),
radioButtons(inputId = "time2save",
label = "Years to save",
inline = FALSE,
choices = list("Last year" = 1,
"Selected series" = 2,
"Null" = 3),
selected = 3
),
br(),
actionBttn("update", label = "Update SWS",
color = "success",
style = "gradient")
),
column(8,
br(),
DT::dataTableOutput('token_val_tab'),
br(),
uiOutput('btn_token1val'),
br(),
uiOutput('btn_token2val'),
br(),
uiOutput('btn_token3val'),
br(),
uiOutput('btn_token4val')
)
)
)
)
)
4.3 ‘server.R’ file
The server file contains the most of the buttons used into the app, the reactiveValue elements and some data loading function. Also, to avoid a too long and complex file, there are connections to external file containing the code to build each tab.
This firs part contains the ‘Token’ tab with the token update process and the year buttons.
shinyServer(function(input, output, session) {
# -- Insert token ----
output$btn_token1 <- renderUI({
textInput(inputId = 'btn_token1', label = "Insert the 'SUA unbalanced' session token", value = NA)
})
output$btn_token2 <- renderUI({
textInput(inputId = 'btn_token2', label = "Insert the 'SUA balanced' session token", value = NA)
})
output$btn_token3 <- renderUI({
textInput(inputId = 'btn_token3', label = "Insert the 'FBS FIAS' session token", value = NA)
})
output$btn_token4 <- renderUI({
textInput(inputId = 'btn_token4', label = "Insert the 'FBS Faostat' session token", value = NA)
})
token_reac <- reactive({
tokenTab <- ReadDatatable('fi_sua_fbs_token')
return(tokenTab)
})
output$token_tab <- DT::renderDataTable( server = FALSE, {
tokenOut <- token_reac()
DT::datatable(tokenOut)
})
observeEvent(input$btn_upd_token, {
tokenTab <- ReadDatatable('fi_sua_fbs_token', readOnly = FALSE)
t1 <- ifelse(is.na(input$btn_token1), tokenTab$token[1], input$btn_token1)
t2 <- ifelse(is.na(input$btn_token2), tokenTab$token[2], input$btn_token2)
t3 <- ifelse(is.na(input$btn_token3), tokenTab$token[3], input$btn_token3)
t4 <- ifelse(is.na(input$btn_token4), tokenTab$token[4], input$btn_token4)
date <- as.character(Sys.Date())
tokenTab[ , token := c(t1, t2, t3, t4) ]
tokenTab[ , last_upd := date]
changeset <- Changeset('fi_sua_fbs_token')
AddModifications(changeset, tokenTab)
Finalise(changeset)
tokenSuaU <<- t1
tokenSuaB <<- t2
tokenFbs <<- t3
tokenFbsFaostat <<- t4
showModal(modalDialog(
title = "Token updated." ,
sprintf("The chosen session will be used in the following tabs.")
))
})
# -- Update button ----
# Check what production to update and which to keep official and manage imbalance by stocks!
#-- Selected year button ----
output$btn_year <- renderUI({
# Country button required
req(input$btn_country)
sel_country <- country_input[country_input$label == input$btn_country, code]
if(sel_country != "-") {
currentYear <- as.numeric(gsub("\\-[0-9]*", "", Sys.Date()))
years_input <- as.character(sort(1961:currentYear, decreasing = TRUE))
# Input details
selectInput(inputId = "btn_year",
label = 'End year',
choices = c("", years_input) #,
# selected = '2017'
)
}
})
#-- Start year button ----
output$btn_start_year <- renderUI({
# Country and year buttons required
req(input$btn_country)
sel_country <- country_input[country_input$label == input$btn_country, code]
if(is.null(input$btn_year)){
min <- '1961'
} else {
min <- input$btn_year
}
if(sel_country != "-") {
currentYear <- as.numeric(gsub("\\-[0-9]*", "", Sys.Date()))
years_input <- as.character(sort(1961:currentYear, decreasing = TRUE))
start_year_input <- years_input[years_input < min]
selectInput(inputId = "btn_start_year",
label = 'Start year',
choices = c("", start_year_input) #,
# selected = '2014'
)
}
})
The frozen and live FBS dataset are fully pulled from the SWS for the selected years and country.
# -- Load FBS frozen ----
frozen_data <- reactiveValues(FBS = data.table(),
SUA = data.table())
live_data <- reactiveValues(FBS = data.table(),
SUAb = data.table(),
SUAbVal = data.table(),
SUAu = data.table(),
Pop = data.table())
observeEvent(input$btn_start_year, {
if(input$btn_start_year != ""){
sel_country <- country_input[country_input$label == input$btn_country, code]
sel_years <- as.character(as.numeric(input$btn_start_year):as.numeric(input$btn_year))
KeyFBS <- DatasetKey(domain = domainComm, dataset = datasetFBSfrozen, dimensions = list(
geographicAreaM49_fi = Dimension(name = "geographicAreaM49_fi", keys = sel_country),
measuredElementSuaFbs = Dimension(name = "measuredElementSuaFbs",
GetCodeList(domainComm, datasetFBSfrozen,"measuredElementSuaFbs" )[,code]),
measuredItemFaostat_L2 = Dimension(name = "measuredItemFaostat_L2",
GetCodeList(domainComm, datasetFBSfrozen,"measuredItemFaostat_L2" )[,code]),
timePointYears = Dimension(name = "timePointYears", keys = as.character(sel_years) )))
withProgress(message = 'Frozen FBS data loading in progress',
value = 0, {
Sys.sleep(0.25)
incProgress(0.25)
FBSfrozen <- GetData(KeyFBS)
Sys.sleep(0.25)
incProgress(0.95)
})
validate(
need(nrow(FBSfrozen) > 0, 'No frozen FBS data for these country and years.')
)
frozen_data$FBS <- FBSfrozen[geographicAreaM49_fi == sel_country]
if(localrun){
if(CheckDebug()){
library(faoswsModules)
SETTINGS = ReadSettings("sws.yml")
R_SWS_SHARE_PATH = SETTINGS[["share"]]
SetClientFiles(SETTINGS[["certdir"]])
GetTestEnvironment(baseUrl = SETTINGS[["server"]],
token = tokenFbs)
}
} else {
R_SWS_SHARE_PATH = "Z:"
SetClientFiles("/srv/shiny-server/.R/QA/")
GetTestEnvironment(baseUrl = "https://swsqa.aws.fao.org:8181",
token = tokenFbs)
}
KeyFBSfias <- DatasetKey(domain = domainComm, dataset = datasetFBSlive, dimensions = list(
geographicAreaM49_fi = Dimension(name = "geographicAreaM49_fi", keys = sel_country),
measuredElementSuaFbs = Dimension(name = "measuredElementSuaFbs",
keys = GetCodeList(domainComm, datasetFBSlive,"measuredElementSuaFbs" )[,code]),
measuredItemFaostat_L2 = Dimension(name = "measuredItemFaostat_L2",
keys = GetCodeList(domainComm, datasetFBSlive,"measuredItemFaostat_L2" )[,code]),
timePointYears = Dimension(name = "timePointYears", keys = as.character(sel_years))))
withProgress(message = 'FBS live data loading in progress',
value = 0, {
Sys.sleep(0.25)
incProgress(0.25)
FBSfias <- GetData(KeyFBSfias)
Sys.sleep(0.25)
incProgress(0.95)
})
live_data$FBS <- FBSfias[geographicAreaM49_fi == sel_country]
validate(need(nrow(live_data$FBS) > 0, 'No FIAS FBS data for these country and years.'))
The datatable filled by the plugin for food processing inconsistencies are loaded.
# Name of the datatable to read for FP (only when country has been chosen)
if(localrun){
sel_country <- country_input[country_input$label == input$btn_country, code]
# FPfile <<- readRDS(filename)
FPfile <<- list(primary = ReadDatatable('fi_fp_imb_primary', where = paste("geographicaream49_fi = '", sel_country, "'", sep = '')),
secondary = ReadDatatable('fi_fp_imb_sec', where = paste("geographicaream49_fi = '", sel_country, "'", sep = '')),
secondaryTot = ReadDatatable('fi_fp_imb_sec_tot', where = paste("geographicaream49_fi = '", sel_country, "'", sep = '')),
tertiary = ReadDatatable('fi_fp_imb_ter', where = paste("geographicaream49_fi = '", sel_country, "'", sep = '')),
quaternary = ReadDatatable('fi_fp_imb_quat', where = paste("geographicaream49_fi = '", sel_country, "'", sep = '')),
NotCovered = ReadDatatable('fi_fp_not_covered', where = paste("geographicaream49_fi = '", sel_country, "'", sep = '')))
} else {
sel_country <- country_input[country_input$label == input$btn_country, code]
# FPfile <<- readRDS(file.path('/work', 'SWS_R_Share', "FisherySUAFBS", filename))
FPfile <<- list(primary = ReadDatatable('fi_fp_imb_primary', where = paste("geographicaream49_fi = '", sel_country, "'", sep = '')),
secondary = ReadDatatable('fi_fp_imb_sec', where = paste("geographicaream49_fi = '", sel_country, "'", sep = '')),
secondaryTot = ReadDatatable('fi_fp_imb_sec_tot', where = paste("geographicaream49_fi = '", sel_country, "'", sep = '')),
tertiary = ReadDatatable('fi_fp_imb_ter', where = paste("geographicaream49_fi = '", sel_country, "'", sep = '')),
quaternary = ReadDatatable('fi_fp_imb_quat', where = paste("geographicaream49_fi = '", sel_country, "'", sep = '')),
NotCovered = ReadDatatable('fi_fp_not_covered', where = paste("geographicaream49_fi = '", sel_country, "'", sep = '')))
}
}
})
The last (Element) button of the upper menu is created and the link to the ‘Overview’ tab file is inserted.
#-- Element button ----
output$btn_element_fbs <- renderUI({
# Country and year buttons required
req(input$btn_country)
sel_country <- country_input[country_input$label == input$btn_country, code]
if(sel_country != "-") {
selectInput(inputId = "btn_element_fbs",
label = 'FBS element',
choices = c("", element_input$label))
}
})
#++ 1 Description tab ----
source("tabs/descriptionTab1.R", local = TRUE)
After the FBS visualization tab, the SUAs must be pulled from the SWS in both, balanced and unbalanced, frozen and live versions for the selected years and country.
#-- Load SUA frozen ----
observeEvent(input$tabs, {
req(input$btn_start_year != '')
sel_country <- country_input[country_input$label == input$btn_country, code]
sel_years <- as.character(as.numeric(input$btn_start_year):as.numeric(input$btn_year))
if(input$tabs == "SUA compare"){
frozenB <- reloadData(data = frozen_data$SUA,
keycountry = sel_country,
minyear = input$btn_start_year,
maxyear = input$btn_year,
keydomain = domainComm,
keydataset = datasetSUABfrozen)
if(!is.null(frozenB)){
frozen_data$SUA <- frozenB
}
validate(need(nrow(frozen_data$SUA) > 0, 'No frozen SUA data for these country and years.'))
liveB <- reloadDataToken(data = live_data$SUAb,
keycountry = sel_country,
minyear = input$btn_start_year,
maxyear = input$btn_year,
keydomain = domainComm,
keydataset = datasetSUABlive,
keytoken = tokenSuaB)
if(!is.null(liveB)){
ValueElements <- c('5922', '5930', '5622', '5630')
liveBval <- copy(liveB)
liveBval <- liveBval[measuredElementSuaFbs %in% ValueElements]
live_data$SUAbVal <- liveBval
# liveB <- liveB[!measuredElementSuaFbs %in% ValueElements]
live_data$SUAb <- liveB
}
validate(need(nrow(live_data$SUAb) > 0, 'No data in SUA balanced for these country and years.'))
}
})
observeEvent(input$tabs, {
req(input$btn_start_year)
req(input$btn_start_year != '')
sel_country <- country_input[country_input$label == input$btn_country, code]
sel_years <- as.character(as.numeric(input$btn_start_year):as.numeric(input$btn_year))
if(input$tabs == "SUA imbalances"){
liveU <- reloadDataToken(data = live_data$SUAu,
keycountry = sel_country,
minyear = input$btn_start_year,
maxyear = input$btn_year,
keydomain = domainComm,
keydataset = datasetSUAUlive,
keytoken = tokenSuaU)
if(!is.null(liveU)){
ValueElements <- c('5922', '5930', '5622', '5630')
# liveU <- liveU[!measuredElementSuaFbs %in% ValueElements]
live_data$SUAu <- liveU
}
validate(need(nrow(live_data$SUAu) > 0,'No SUA unbalanced data for these country and years.'))
}
})
After data are ready the building of the second tab starts with the buttons and the recall to the second and third tab. The third tab is merely descriptive and no interactive feature is inserted.
#-- FBS group button ----
output$btn_group_fbs <- renderUI({
# Country and year buttons required
req(input$btn_country)
req(input$btn_start_year != '')
fbs_group_input <- merge(data.table(code = as.character(c(seq(10, 90, by = 10), 99))),
groups_input , by = 'code')
# selectInput
checkboxGroupInput(inputId = "btn_group_fbs",
label = 'FBS group',
choices = c('All', fbs_group_input$label),
selected = NULL)#fbs_group_input$label)
})
#-- Element group button ----
output$btn_element_group <- renderUI({
# Country and year buttons required
req(input$btn_country) #, input$btn_group_fbs)
req(input$btn_start_year != '')
sel_country <- country_input[country_input$label == input$btn_country, code]
if(sel_country != "-") {
radioButtons(inputId = "btn_element_group",
label = 'Element group',
inline = TRUE,
choices = elementGroups,
selected = NULL)
}
})
#-- SUA element button ----
output$btn_element_sua <- renderUI({
# Country and year buttons required
req(input$btn_country, input$btn_element_group)
req(input$btn_start_year != '')
if(input$btn_element_group == 'All'){
chosen <- sua_element_input$label
} else if(input$btn_element_group == 'Primary'){
chosen <- sua_element_input[code %in% primaryEl, ]$label
} else if(input$btn_element_group == 'Nutrients') {
chosen <- sua_element_input[code %in% NutrientsEl, ]$label
} else if(input$btn_element_group == 'SUA'){
chosen <- sua_element_input[code %in% SUAel, ]$label
} else {
chosen <- NULL
}
checkboxGroupInput(inputId = "btn_element_sua",
label = 'SUA element',
choices = sua_element_input$label,
selected = chosen)
})
#++ 2 Comparing SUA tab ----
source("tabs/comparingSuaTab2.R", local = TRUE)
#++ 2bis Imbalance tab ----
source("tabs/imbalanceTab2.R", local = TRUE)
The fourth and fifth tab are now introduced (please note in the code these tabs are called ‘tab 3’ and ‘tab 4’ as the ‘SUA imbalances’ is an additional tab not planned in the first version). The shiny allows the user to start from any tab and to have the data loaded the first time they are required through the functions reloadData and reloadDataToken, i.e. if the user skip the first natural tab where the SUA should be loaded (SUA compare tab) and goes directly to any other tab, the shiny checks for the data loaded and their parameters (country and years) and if necessary loads the data otherwise it keeps using the already loaded ones.
#-- FBS group button Tab3 ----
output$btn_group_fbs_tab3 <- renderUI({
# Country and year buttons required
req(input$btn_country)
req(input$btn_start_year != '')
fbs_group_input <- merge(data.table(code = as.character(c(seq(10, 90, by = 10), 99))), groups_input , by = 'code')
selectInput(inputId = "btn_group_fbs_tab3",
label = 'FBS group',
choices = c('',fbs_group_input$label),
selected = input$btn_group_fbs)
})
#-- ICS product button Tab3 ----
output$btn_ics_prod_tab3 <- renderUI({
# Country and year buttons required
req(input$btn_country, input$btn_group_fbs_tab3)
req(input$btn_start_year != '')
# code of FBS group chosen
group_sel <- groups_input[ label == input$btn_group_fbs_tab3]$code
# ICS product in the chosen FBS group
ICSinput_code <- l2l1[code_l1 == group_sel ]$code_l2
ICSinput <- groups_input[ code %in% ICSinput_code]$label
checkboxGroupInput(inputId = "btn_ics_prod_tab3",
label = 'ICS product',
choices = ICSinput,
selected = ICSinput)
})
#++ 3 FBS group by ICS product tab ----
source("tabs/productTab3.R", local = TRUE)
#-- FBS group button Tab4 ----
output$btn_group_fbs_tab4 <- renderUI({
# Country and year buttons required
req( input$btn_country, input$btn_year, input$btn_start_year)
req(input$btn_start_year != '')
fbs_group_input <- merge( data.table(code = as.character(c(seq(10, 90, by = 10), 99))), groups_input , by = 'code')
selectInput(inputId = "btn_group_fbs_tab4",
label = 'FBS group',
choices = c('',fbs_group_input$label),
selected = input$btn_group_fbs)
})
#-- ICS product button Tab4 ----
output$btn_ics_prod_tab4 <- renderUI({
# Country and year buttons required
req(input$btn_country, input$btn_group_fbs_tab4, input$btn_year, input$btn_start_year)
req(input$btn_start_year != '')
# code of FBS group chosen
group_sel <- groups_input[ label == input$btn_group_fbs_tab4]$code
# ICS product in the chosen FBS group
ICSinput_code <- l2l1[code_l1 == group_sel ]$code_l2
ICSinput <- groups_input[ code %in% ICSinput_code]$label
selectInput(inputId = "btn_ics_prod_tab4",
label = 'ICS product',
choices = c('',ICSinput))
})
#-- If SUA not loaded yet ----
observeEvent(input$btn_ics_prod_tab4, {
req(input$btn_start_year)
req(input$btn_start_year != '')
sel_country <- country_input[country_input$label == input$btn_country, code]
sel_years <- as.character(as.numeric(input$btn_start_year):as.numeric(input$btn_year))
frozenB <- reloadData(data = frozen_data$SUA,
keycountry = sel_country,
minyear = input$btn_start_year,
maxyear = input$btn_year,
keydomain = domainComm,
keydataset = datasetSUABfrozen)
if(!is.null(frozenB)){
frozen_data$SUA <- frozenB
}
validate(need(nrow(frozen_data$SUA) > 0, 'No forzen SUA data for these country and years.'))
})
#-- SUA element group Tab4 ----
output$btn_element_group_tab4 <- renderUI({
# Country and year buttons required
req(input$btn_start_year != '')
# req(input$btn_ics_prod_tab4)
sel_country <- country_input[country_input$label == input$btn_country, code]
if(sel_country != "-") {
radioButtons(inputId = "btn_element_group_tab4",
label = 'Element group',
inline = TRUE,
choices = elementGroups,
selected = 'All')
}
})
#-- SUA element Tab4 ----
output$btn_element_sua_tab4 <- renderUI({
# Country and year buttons required
req(input$btn_country, input$btn_year, input$btn_element_group_tab4) #, input$btn_ics_prod_tab4)
req(input$btn_start_year != '')
SUAfrozen <- frozen_data$SUA
SUAelem_input <- sua_element_input[ code %in% unique(SUAfrozen$measuredElementSuaFbs), ]
if(input$btn_element_group_tab4 == 'All'){
chosen <- SUAelem_input$label
} else if(input$btn_element_group_tab4 == 'Primary'){
chosen <- SUAelem_input[code %in% primaryEl, ]$label
} else if(input$btn_element_group_tab4 == 'Nutrients') {
chosen <- SUAelem_input[code %in% NutrientsEl, ]$label
} else if(input$btn_element_group_tab4 == 'SUA'){
chosen <- SUAelem_input[code %in% SUAel, ]$label
} else {
chosen <- NULL
}
checkboxGroupInput(inputId = "btn_element_sua_tab4",
label = 'SUA element',
choices = SUAelem_input$label,
selected = chosen)
})
#++ 4 SUA element Tab4 ----
source("tabs/elementTab4.R", local = TRUE)
The ‘Global production’ tab is the first tab where the user can start active interaction and update SWS information. For this reason also new elements to store old and new objects are created: updated_data where to store the updated versions of SUAs and FBSs, updated_mappings to store new mappings for species and commodities and updated_table to store new imbalances.
#-- Place for updated datasets ----
updated_data <- reactiveValues(SUAunbal = data.table(),
SUAbal = data.table(),
FBSfias = data.table(),
FBSfaostat = data.table())
# live_data <- reactiveValues(FBS = data.table(),
# SUAb = data.table(),
# SUAu = data.table())
updated_table <- reactiveValues(NegAv = data.table(),
FPproblems = data.table())
The ‘Global production and the ’Commodities tab’ with the corresponding buttons follow with the InitialDatasets reactiveValue element where they are stored. The ‘Link table’, the ‘Balancing elelements’ and the ‘Extraction rates’ are additional working tabs where the user can modify the SWS datatables directly from the shiny.
#-- FBS group button Tab5 ----
output$btn_group_fbs_tab5 <- renderUI({
# Country and year buttons required
req(input$btn_country, input$btn_year, input$btn_start_year)
req(input$btn_start_year != '')
fbs_group_input <- merge(data.table(code = as.character(c(seq(10, 90, by = 10), 99))), groups_input , by = 'code')
selectInput(inputId = "btn_group_fbs_tab5",
label = 'FBS group',
choices = c('',fbs_group_input$label),
selected = input$btn_group_fbs,
multiple = TRUE)
})
InitialDatasets <- reactiveValues(GP = data.table(),
CDB = data.table(),
CDBVal = data.table())
#++ 5 Global Production Tab5 ----
source("tabs/gpTab5.R", local = TRUE)
#-- FBS group button Tab6 ----
output$btn_group_fbs_tab6 <- renderUI({
# Country and year buttons required
req(input$btn_country, input$btn_year, input$btn_start_year)
req(input$btn_start_year != '')
fbs_group_input <- merge(data.table(code = as.character(c(seq(10, 90, by = 10), 99))), groups_input , by = 'code')
selectInput(inputId = "btn_group_fbs_tab6",
label = 'FBS group',
choices = c('',fbs_group_input$label),
selected = input$btn_group_fbs,
multiple = TRUE)
})
#-- ICS product button Tab6 ----
output$btn_ics_prod_tab6 <- renderUI({
# Country and year buttons required
req(input$btn_country, input$btn_year, input$btn_start_year,
input$btn_group_fbs_tab6)
req(input$btn_start_year != '')
# code of FBS group chosen
group_sel <- groups_input[ label %in% input$btn_group_fbs_tab6]$code
# ICS product in the chosen FBS group
ICSinput_code <- l2l1[code_l1 %in% group_sel ]$code_l2
ICSinput <- groups_input[ code %in% ICSinput_code]$label
selectInput(inputId = "btn_ics_prod_tab6",
label = 'ICS product',
choices = c('', ICSinput),
multiple = TRUE)
})
#-- SUA element Tab6 ----
output$btn_element_cdb_tab6 <- renderUI({
# Country and year buttons required
req(input$btn_country, input$btn_year, input$btn_start_year) #, input$btn_ics_prod_tab6)
req(input$btn_start_year != '')
SUAfrozen <- frozen_data$SUA
SUAelem_input <- sua_element_input[ code %in% c('5510', '5610', '5910', '5912', '5922', '5930', '5622', '5630'), ]
# NOTE one of '5951', '5912' has to be changed!!!
checkboxGroupInput(inputId = "btn_element_cdb_tab6",
label = 'SUA element',
choices = SUAelem_input$label,
selected = SUAelem_input$label)
})
##++ 6 Commodity Tab6 ----
source("tabs/cdbTab6.R", local = TRUE)
source("tabs/linktable.R", local = TRUE)
source("tabs/balancingelements.R", local = TRUE)
source("tabs/extrRates.R", local = TRUE)
The ‘Data validation’ tab is the main and most complex tab of the shiny app described in the corresponding sub-paragraph. In the ‘server.R’ file there are only buttons and recall to the file for this tab. The recall to file for the ‘Data update’ and ‘Data saving’ tab follow.
#-- FBS group button Tab7 ----
output$btn_group_fbs_tab7 <- renderUI({
# Country and year buttons required
req(input$btn_country, input$btn_year, input$btn_start_year)
req(input$btn_start_year != '')
fbs_group_input <- merge(data.table(code = as.character(c(seq(10, 90, by = 10), 99))), groups_input , by = 'code')
selectInput(inputId = "btn_group_fbs_tab7",
label = 'FBS group',
choices = fbs_group_input$label,
selected = NULL, #input$btn_group_fbs,
multiple = TRUE)
})
#-- ICS product button Tab7 ----
output$btn_ics_prod_tab7 <- renderUI({
# Country and year buttons required
req(input$btn_country, input$btn_year, input$btn_start_year) #, input$btn_group_fbs_tab7)
req(input$btn_start_year != '')
# code of FBS group chosen
# if(!is.null(input$btn_group_fbs_tab7)){
group_sel <- groups_input[ label %in% input$btn_group_fbs_tab7]$code
# ICS product in the chosen FBS group
ICSinput_code <- l2l1[code_l1 %in% group_sel ]$code_l2
ICSinput <- groups_input[ code %in% ICSinput_code]$label
selectInput(inputId = "btn_ics_prod_tab7",
label = 'ICS product',
choices = c('All', ICSinput),
selected = NULL,
multiple = TRUE)
# }
})
#-- SUA element group Tab7 ----
output$btn_element_group_tab7 <- renderUI({
# Country and year buttons required
rep(input$btn_country) # req(input$btn_ics_prod_tab7)
req(input$btn_start_year != '')
#if(!is.null(input$btn_group_fbs_tab7)){
sel_country <- country_input[country_input$label == input$btn_country, code]
if(sel_country != "-") {
radioButtons(inputId = "btn_element_group_tab7",
label = 'Element group',
inline = TRUE,
choices = elementGroups)
}
# }
})
#-- SUA element Tab7 ----
output$btn_sua_elem_tab7 <- renderUI({
# Country and year buttons required
req(input$btn_element_group_tab7)
req(input$btn_start_year != '')
# if(!is.null(input$btn_group_fbs_tab7)){
if(input$btn_element_group_tab7 == 'All'){
chosen <- sua_element_input$label
} else if(input$btn_element_group_tab7 == 'Primary'){
chosen <- sua_element_input[code %in% primaryEl, ]$label
} else if(input$btn_element_group_tab7 == 'Nutrients') {
chosen <- sua_element_input[code %in% NutrientsEl, ]$label
} else if(input$btn_element_group_tab7 == 'SUA'){
chosen <- sua_element_input[code %in% SUAel, ]$label
} else {
chosen <- NULL
}
selectInput(inputId = "btn_sua_elem_tab7",
label = 'SUA element',
choices = sua_element_input$label,
selected = chosen,
multiple = TRUE)
# }
})
#++ 7 Validation Tab6 ----
source("tabs/validationTab7.R", local = TRUE)
#++ 8 Consequences tab ----
source("tabs/consequencesTab8.R", local = TRUE)
#++ 9 Consequences tab ----
source("tabs/savingTab.R", local = TRUE)
})
4.3.1 ‘Overview’ tab
The ‘Overview’ tab contains the comparison between the ‘live’ and ‘frozen’ FBS by major group and grand total. Both table and plots are available. In this first chunk the two datasets are recalled, merged and the difference between values in computed. If no value is available for only one of the two then a zero is imputed and difference is calculated.
# First tab, Description tab
overviewTab_reac <- reactive({
req(input$btn_country, input$btn_year, input$btn_start_year, input$btn_element_fbs)
sel_country <- country_input[country_input$label == input$btn_country, code]
sel_years <- as.character(as.numeric(input$btn_start_year):as.numeric(input$btn_year))
sel_elements_fbs <- as.character(element_input[label == input$btn_element_fbs]$code)
sel_fbs_groups <- as.character(c(seq(10, 90, by = 10), 99))
validate(
need(nrow(frozen_data$FBS) > 0, "No frozen FBS data for this country. Please select another country.")
)
validate(
need(nrow(live_data$FBS) > 0, "No FBS data for this country. Please select another country.")
)
FBSfias <- live_data$FBS[measuredElementSuaFbs == sel_elements_fbs ]
FBSfrozen <- frozen_data$FBS
FBSfrozen <- FBSfrozen[measuredElementSuaFbs == sel_elements_fbs]
# Now only showing value present both in frozen and live, CHANGE?
frozenVSlive <- merge(FBSfrozen, FBSfias,
by = c('geographicAreaM49_fi', 'measuredItemFaostat_L2',
'measuredElementSuaFbs', 'timePointYears'),
suffixes = c('Frozen', 'Live'), all = TRUE)
frozenVSlive <- frozenVSlive[ , c( 'geographicAreaM49_fi', 'measuredItemFaostat_L2',
'measuredElementSuaFbs', 'timePointYears',
'flagObservationStatusFrozen', 'flagMethodFrozen',
'flagObservationStatusLive', 'flagMethodLive') := list(as.character(geographicAreaM49_fi),
as.character(measuredItemFaostat_L2),
as.character(measuredElementSuaFbs),
as.character(timePointYears),
as.character(flagObservationStatusFrozen),
as.character(flagMethodFrozen),
as.character(flagObservationStatusLive),
as.character(flagMethodLive))]
frozenVSlive$flagObservationStatusFrozen <- as.character( frozenVSlive$flagObservationStatusFrozen)
frozenVSlive$flagObservationStatusLive <- as.character( frozenVSlive$flagObservationStatusLive)
frozenVSlive[is.na(ValueFrozen), flagObservationStatusFrozen := 'O']
frozenVSlive[is.na(ValueLive), flagObservationStatusLive := 'O']
frozenVSlive[is.na(ValueFrozen), flagMethodFrozen := '-']
frozenVSlive[is.na(ValueLive), flagMethodLive := '-']
frozenVSlive[is.na(ValueFrozen), ValueFrozen := 0]
frozenVSlive[is.na(ValueLive), ValueLive := 0]
frozen2plot <- frozenVSlive[ , .(geographicAreaM49_fi,
measuredItemFaostat_L2,
measuredElementSuaFbs,
timePointYears,
ValueFrozen)]
frozen2plot[ , type := 'Frozen']
live2plot <- frozenVSlive[ , .(geographicAreaM49_fi,
measuredItemFaostat_L2,
measuredElementSuaFbs,
timePointYears,
ValueLive)]
live2plot[ , type := 'Live']
setnames(frozen2plot, 'ValueFrozen', 'Value')
setnames(live2plot, 'ValueLive', 'Value')
data4plot <- rbind(frozen2plot, live2plot)
frozenVSlive <- frozenVSlive
return(list(tab = frozenVSlive, plot = data4plot))
})
The table and the plot follow now, the grand total is added to the other groups and for differences grater than |0.001| the table insert a red value instead then black.
output$fbs_fias_tab1 <- DT::renderDataTable( server = FALSE, {
req(input$btn_country, input$btn_year, input$btn_start_year, input$btn_element_fbs)
fbs_fias_tab_out <- copy(overviewTab_reac()$tab)
if(nrow(fbs_fias_tab_out) > 0){
grandtotal <- copy(fbs_fias_tab_out)
grandtotal$flagObservationStatusFrozen <- factor(grandtotal$flagObservationStatusFrozen,
levels = c('M', 'O', 'N', '', 'X', 'T', 'E', 'I'),
ordered = TRUE)
grandtotal$flagObservationStatusLive <- factor(grandtotal$flagObservationStatusLive,
levels = c('M', 'O', 'N', '', 'X', 'T', 'E', 'I'),
ordered = TRUE)
grandtotal <- grandtotal[ , c('ValueFrozen', 'ValueLive', 'measuredItemFaostat_L2',
'flagObservationStatusFrozen', 'flagMethodFrozen',
'flagObservationStatusLive', 'flagMethodLive') := list(sum(ValueFrozen, na.rm = TRUE),
sum(ValueLive, na.rm = TRUE),
'Total',
max(flagObservationStatusFrozen), 's',
max(flagObservationStatusLive), 's'),
by = c('geographicAreaM49_fi',
'measuredElementSuaFbs',
'timePointYears')]
grandtotal$flagObservationStatusFrozen <- as.character(grandtotal$flagObservationStatusFrozen)
grandtotal$flagObservationStatusLive <- as.character(grandtotal$flagObservationStatusLive)
setkey(grandtotal)
grandtotal <- grandtotal[!duplicated(grandtotal)]
fbs_fias_tot <- rbind(fbs_fias_tab_out, grandtotal)
setnames(fbs_fias_tot, c('geographicAreaM49_fi', 'measuredItemFaostat_L2',
'measuredElementSuaFbs', 'timePointYears',
'flagObservationStatusFrozen', 'flagMethodFrozen',
'flagObservationStatusLive', 'flagMethodLive'),
c('Country', 'FBSgroup', 'Element', 'Year', 'FlagFrozen1', 'FlagFrozen2',
'FlagLive1', 'FlagLive2'))
fbs_fias_tot[ , Diff := round(ValueFrozen - ValueLive, 3)]
DT::datatable(fbs_fias_tot, extensions = 'Buttons', filter = 'top',
rownames = FALSE, options = list(dom = 'Bfrtip',
buttons = c('csv', 'excel', 'pdf'))) %>%
formatStyle(columns = c('Diff'), target = 'row',
color = styleInterval(c(-0.001, 0.001), c('red', ' ', 'red')))
} else {
DT::datatable(data.table())
}
})
output$gg_plot_tab1 <- renderPlot({
req(input$btn_country, input$btn_year, input$btn_start_year, input$btn_element_fbs)
fbs_fias_data <- copy(overviewTab_reac()$plot)
if(nrow(fbs_fias_data) > 0){
grandtotal <- copy(fbs_fias_data)
grandtotal <- grandtotal[ , c('Value', 'measuredItemFaostat_L2') := list(sum(Value, na.rm = TRUE), 'Total'),
by = c('geographicAreaM49_fi',
'measuredElementSuaFbs',
'timePointYears', 'type')]
setkey(grandtotal)
grandtotal <- grandtotal[!duplicated(grandtotal)]
fbs_fias_tot <- rbind(fbs_fias_data, grandtotal)
# Make grand total
ggplot(data = fbs_fias_tot, aes(x = timePointYears, y = Value)) +
geom_line(aes(group = type, color = type), size = 0.7) +
facet_wrap( ~ measuredItemFaostat_L2, scales="free") +
labs(x = 'Year', color = '') +
theme(text = element_text(size= 15))
} else {
ggplot(fbs_fias_data, aes(x = timePointYears, y = Value)) + geom_blank()
}
})
4.3.2 ‘SUA compare’ tab
The same rationale used for the first tab is used for the second one but now to compare SUAs. The upload of the SUA data is done in the ‘server.R’ file now ‘live’ and ‘frozen’ SUAs are merged and the difference computed. The SUAs are filtered by major groups and elements. The reactive functions is where the operations are performed and the renderDataTable function structure the output table.
# Second tab, comparing SUA versions tab
SUAcomparingTab_reac <- reactive({
req(input$btn_country, input$btn_year, input$btn_start_year, input$btn_group_fbs, input$btn_element_sua)
sel_country <- country_input[country_input$label == input$btn_country, code]
sel_years <- as.character(as.numeric(input$btn_start_year):as.numeric(input$btn_year))
if(any(input$btn_group_fbs == 'All')){
sel_group_fbs <- as.character(groups_input$code)
} else {
sel_group_fbs <- as.character(groups_input[label %in% input$btn_group_fbs]$code)
}
sel_element_sua <- as.character(sua_element_input[ label %in% input$btn_element_sua]$code )
l2l1 <- ReadDatatable('ics_l1_2_ics_l2')
ics2select <- l2l1[code_l1 %in% sel_group_fbs ]$code_l2
# if(CheckDebug()){
#
# library(faoswsModules)
# SETTINGS = ReadSettings("sws.yml")
#
# ## If you're not on the system, your settings will overwrite any others
# R_SWS_SHARE_PATH = SETTINGS[["share"]]
#
# ## Define where your certificates are stored
# SetClientFiles(SETTINGS[["certdir"]])
#
# ## Get session information from SWS. Token must be obtained from web interface
# GetTestEnvironment(baseUrl = SETTINGS[["server"]],
# token = tokenSuaB)
#
# }
#
# # R_SWS_SHARE_PATH = "Z:"
# # SetClientFiles("/srv/shiny-server/shinyFisheriesCommodities")
# # GetTestEnvironment(baseUrl = "https://hqlqasws1.hq.un.fao.org:8181/sws",
# # token = tokenSuaB)
#
#
# KeySUAbal <- DatasetKey(domain = "FisheriesCommodities", dataset = "fi_sua_balanced", dimensions = list(
# geographicAreaM49_fi = Dimension(name = "geographicAreaM49_fi", keys = sel_country),
# measuredElementSuaFbs = Dimension(name = "measuredElementSuaFbs",
# keys = sel_element_sua), # Or, if all elements, GetCodeList("FisheriesCommodities", "fi_fbs_fias_control","measuredElementSuaFbs" )[,code])
# measuredItemFaostat_L2 = Dimension(name = "measuredItemFaostat_L2",
# keys = ics2select),
# timePointYears = Dimension(name = "timePointYears", keys = sel_years )))
#
# withProgress(message = 'SUA balanced data loading in progress',
# value = 0, {
#
# Sys.sleep(0.25)
# incProgress(0.25)
# SUAbal <- GetData(KeySUAbal)
# Sys.sleep(0.75)
# incProgress(0.95)
# })
validate(
need(nrow(frozen_data$SUA) > 0, "No frozen SUA data for this country. Please select another country.")
)
validate(
need(nrow(live_data$SUAb) > 0, "No SUA data for this country. Please select another country.")
)
SUAbal <- live_data$SUAb[measuredElementSuaFbs %in% sel_element_sua & measuredItemFaostat_L2 %in% ics2select]
SUAbal <- rbind(SUAbal, live_data$SUAbVal[measuredElementSuaFbs %in% sel_element_sua & measuredItemFaostat_L2 %in% ics2select])
SUAfrozen <- frozen_data$SUA[measuredElementSuaFbs %in% sel_element_sua & measuredItemFaostat_L2 %in% ics2select]
# Now only showing value present both in frozen and live, CHANGE?
SUAfrozenVSlive <- merge(SUAfrozen, SUAbal,
by = c('geographicAreaM49_fi', 'measuredItemFaostat_L2',
'measuredElementSuaFbs', 'timePointYears'),
suffixes = c('Frozen', 'Live'),
all = TRUE)
SUAfrozenVSlive[is.na(ValueFrozen), ValueFrozen := 0]
SUAfrozenVSlive[is.na(ValueLive), ValueLive := 0]
SUAfrozenVSlive[measuredElementSuaFbs == '5423', ValueLive := ValueLive]
frozen2show <- SUAfrozenVSlive[measuredElementSuaFbs %in% sel_element_sua]
frozen2show <- merge(frozen2show, l2l1[ , .(code_l1, code_l2)],
by.x = 'measuredItemFaostat_L2', by.y = 'code_l2')
return(frozen2show)
})
output$sua_comp_tab2 <- DT::renderDataTable( server = FALSE, {
sua_comp_tab_out <- copy(SUAcomparingTab_reac())
setnames(sua_comp_tab_out, c('geographicAreaM49_fi', 'measuredItemFaostat_L2',
'measuredElementSuaFbs', 'timePointYears',
'flagObservationStatusFrozen', 'flagMethodFrozen',
'flagObservationStatusLive', 'flagMethodLive', 'code_l1'),
c('Country', 'ICSprod', 'Element', 'Year', 'Fr1', 'Fr2',
'Li1', 'Li2', 'FBSgroup'))
sua_comp_tab_out[ , Diff := round(ValueFrozen - ValueLive, 3)]
setcolorder(sua_comp_tab_out, c('Country', 'FBSgroup', 'ICSprod', 'Element', 'Year',
'ValueFrozen', 'Fr1', 'Fr2',
'ValueLive', 'Li1', 'Li2', 'Diff'))
DT::datatable(sua_comp_tab_out, extensions = 'Buttons', filter = 'top',
rownames = FALSE, options = list(pageLength = 25,
dom = 'Bfrtip',
buttons = c('csv', 'excel', 'pdf'))) %>%
formatStyle(columns = c('Diff'), target = 'row',
color = styleInterval(c(-0.001, 0.001), c('red', ' ', 'red')))
#backgroundColor = styleInterval(0, c(' ', 'red')))
})
4.3.3 ‘SUA imbalance’ tab
The imbalance tab is, again, only a descriptive tab. Both SUA balanced and unbalanced are loaded and combined to show:
a table with the differences between SUA unbalanced and SUA balanced productions (bottom table)
a table with the imbalances found during the plugin calculations (right side table)
the plots with the imbalance series by product.
# Create datatable
SUAimbalanceTab_reac <- reactive({
req(input$btn_country, input$btn_year, input$btn_start_year)
sel_country <- country_input[country_input$label == input$btn_country, code]
sel_years <- as.character(as.numeric(input$btn_start_year):as.numeric(input$btn_year))
imbalance_tab <- ReadDatatable('imbalance_tab')
imbalance_tab_country <- imbalance_tab[geographicaream49_fi == sel_country & timepointyears %in% sel_years]
SUAbal <- reloadDataToken(data = live_data$SUAb,
keycountry = sel_country,
minyear = input$btn_start_year,
maxyear = input$btn_year,
keydomain = domainComm,
keydataset = datasetSUABlive,
keytoken = tokenSuaB)
if(!is.null(SUAbal)){
ValueElements <- c('5922', '5930', '5622', '5630')
SUAbalval <- copy(SUAbal)
SUAbalval <- SUAbalval[measuredElementSuaFbs %in% ValueElements]
SUAbal <- SUAbal[!measuredElementSuaFbs %in% ValueElements]
live_data$SUAbVal <- SUAbalval
live_data$SUAb <- SUAbal
} else {
SUAbalval <- live_data$SUAbVal
SUAbal <- live_data$SUAb
}
SUAbal <- live_data$SUAb[measuredElementSuaFbs == '5510']
SUArou <- SUAbal[measuredElementSuaFbs == '5166']
SUAunbalTot <- reloadDataToken(data = live_data$SUAu,
keycountry = sel_country,
minyear = input$btn_start_year,
maxyear = input$btn_year,
keydomain = domainComm,
keydataset = datasetSUAUlive,
keytoken = tokenSuaU)
if(!is.null(SUAunbalTot)){
ValueElements <- c('5922', '5930', '5622', '5630')
SUAunbalTot <- SUAunbalTot[!measuredElementSuaFbs %in% ValueElements]
live_data$SUAu <- SUAunbalTot[!measuredElementSuaFbs %in% ValueElements]
} else {
SUAunbalTot <- live_data$SUAu
}
SUAunbal <- SUAunbalTot[measuredElementSuaFbs == '5510']
prodCompare <- merge(SUAunbal, SUAbal, by = c("geographicAreaM49_fi","measuredElementSuaFbs",
"measuredItemFaostat_L2", "timePointYears"),
suffixes = c('Unbal', 'Bal'), all = TRUE)
prodCompare[is.na(ValueUnbal) , ValueUnbal := 0]
return(list(imb = imbalance_tab_country, prod = prodCompare, rou = SUArou))
})
output$sua_imb_tab2 <- DT::renderDataTable( server = FALSE, {
req(input$btn_country, input$btn_year, input$btn_start_year)
sua_imb_tab_out <- copy(SUAimbalanceTab_reac()$imb)
validate(
need(nrow(sua_imb_tab_out) > 0,
'No imbalance to show.')
)
setnames(sua_imb_tab_out, c('geographicaream49_fi', 'measureditemfaostat_l2',
'timepointyears'),
c('Country', 'ICSprod', 'Year'))
setcolorder(sua_imb_tab_out, c('Country', 'ICSprod', 'Year', 'availability'))
DT::datatable(sua_imb_tab_out, extensions = 'Buttons', filter = 'top',
rownames = FALSE, options = list(pageLength = 10,
dom = 'Bfrtip',
buttons = c('csv', 'excel', 'pdf')))
})
output$gg_plot_tab2bis <- renderPlot({
req(input$btn_country, input$btn_year, input$btn_start_year)
sua_imb_tab_out <- copy(SUAimbalanceTab_reac()$imb)
validate(
need(nrow(sua_imb_tab_out) > 0,
'No imbalance to show.')
)
ggplot(data = sua_imb_tab_out, aes(x = timepointyears, y = availability, fill = measureditemfaostat_l2)) +
# geom_bar(stat = 'identity', position = 'dodge') +
geom_histogram(stat = 'identity', binwidth = 0.5) +
facet_wrap( ~ measureditemfaostat_l2, scales="free") +
labs(x = 'Year') +
theme(text = element_text(size=15))
})
output$sua_prod_diff_tab2 <- DT::renderDataTable( server = FALSE, {
req(input$btn_country, input$btn_year, input$btn_start_year)
prodCompare <- copy(SUAimbalanceTab_reac()$prod)
setnames(prodCompare, c('geographicAreaM49_fi', 'measuredItemFaostat_L2',
'timePointYears', 'measuredElementSuaFbs'),
c('Country', 'ICSprod', 'Year', 'Element'))
prodCompare[ , Diff := (ValueUnbal - ValueBal)]
DT::datatable(prodCompare, extensions = 'Buttons', filter = 'top',
rownames = FALSE, options = list(pageLength = 25,
dom = 'Bfrtip',
buttons = c('csv', 'excel', 'pdf')))
})
4.3.4 ‘FBS by ICS’ tab
This table recalls the SUA balanced and loads it is needed. It filters the element chosen from the upper menu and displays, both in tab and graph, the corresponding element of each SUA product belonging to the selected major group. The user can then see the time series of each element. The table updates when the element chosen in the upper menu changes. By default all the ICS products belonging to the selected major group are selected. The user can deselect any group and the plot is updated on the fly.
# Third tab, FBS groups by ICS product tab
SUAicsTab_reac <- reactive({
req(input$btn_group_fbs_tab3, input$btn_ics_prod_tab3,
input$btn_year, input$btn_country, input$btn_start_year)
sel_country <- country_input[country_input$label == input$btn_country, code]
sel_years <- as.character(as.numeric(input$btn_start_year):as.numeric(input$btn_year))
# sel_group_fbs <- as.character(groups_input[label %in% input$btn_group_fbs_tab3]$code)
sel_ics_prod <- as.character(groups_input[label %in% input$btn_ics_prod_tab3]$code )
# sel_element_sua <- as.character(element_input[ label %in% input$btn_element_fbs]$code )
SUAbalIcs <- reloadDataToken(data = live_data$SUAb,
keycountry = sel_country,
minyear = input$btn_start_year,
maxyear = input$btn_year,
keydomain = domainComm,
keydataset = datasetSUABlive,
keytoken = tokenSuaB)
if(!is.null(SUAbalIcs)){
ValueElements <- c('5922', '5930', '5622', '5630')
SUAbalIcsval <- copy(SUAbalIcs)
SUAbalIcsval <- SUAbalIcsval[!measuredElementSuaFbs %in% ValueElements]
SUAbalIcs <- SUAbalIcs[!measuredElementSuaFbs %in% ValueElements]
live_data$SUAb <- SUAbalIcs
live_data$SUAbVal <- SUAbalIcsval
} else {
SUAbalIcs <- live_data$SUAb
SUAbalIcsval <- live_data$SUAbVal
}
SUAbalIcs <- rbind(SUAbalIcs, SUAbalIcsval)
SUAbalIcs <- SUAbalIcs[measuredItemFaostat_L2 %in% sel_ics_prod]
tab2show <- merge(SUAbalIcs, l2l1[ , .(code_l1, code_l2)],
by.x = 'measuredItemFaostat_L2', by.y = 'code_l2')
return(tab2show)
})
output$sua_ics_tab3 <- DT::renderDataTable( server = FALSE, {
sua_ics_tab_out <- copy(SUAicsTab_reac())
setnames(sua_ics_tab_out, c('geographicAreaM49_fi', 'measuredItemFaostat_L2',
'measuredElementSuaFbs', 'timePointYears',
'flagObservationStatus', 'flagMethod', 'code_l1'),
c('Country', 'ICSprod', 'Element', 'Year', 'F1', 'F2', 'FBSgroup'))
setcolorder(sua_ics_tab_out, c('Country', 'FBSgroup', 'ICSprod', 'Element', 'Year',
'Value', 'F1', 'F2'))
DT::datatable(sua_ics_tab_out, extensions = 'Buttons', filter = 'top',
rownames = FALSE, options = list(pageLength = 25,
dom = 'Bfrtip',
buttons = c('csv', 'excel', 'pdf')))
})
output$gg_plot_tab3 <- renderPlot({
req(input$btn_group_fbs_tab3, input$btn_ics_prod_tab3, input$btn_element_fbs,
input$btn_year, input$btn_country, input$btn_start_year)
# sel_element_sua <- as.character(element_input[ label %in% input$btn_element_sua]$code )
sel_elements_fbs <- as.character(element_input[label == input$btn_element_fbs]$code)
suaIcs_data <- copy(SUAicsTab_reac())
suaIcs_data <- suaIcs_data[measuredElementSuaFbs == sel_elements_fbs ]
validate(
need(nrow(suaIcs_data) > 0,
'The FBS element selected in the upper right part of the screen is not calculated in the SUA.
Please choose a different element.'))
# Make grand total
ggplot(data = suaIcs_data, aes(x = timePointYears, y = Value)) +
geom_line(aes(group = measuredItemFaostat_L2, color = measuredItemFaostat_L2), size = 0.7) +
# geom_text(data = suaIcs_data[timePointYears == as.numeric(input$btn_year)],
# aes(label = measuredItemFaostat_L2, color = measuredItemFaostat_L2, check_overlap = TRUE),
# hjust = 0.7, vjust = 1, show_guide = F) +
labs(x = 'Year', color = '') +
theme(text = element_text(size= 15))
})
4.3.5 ‘ICS by Element’ tab
This tab has exactly the same structure as the previous one but filter all the element for the selected ICS product. By default all the elements are selected, the user can deselect any element and the tab is updated on the fly.
# Fourth tab, ICS product by element tab
SUAelemTab_reac <- reactive({
req(input$btn_group_fbs_tab4, input$btn_ics_prod_tab4, input$btn_element_sua_tab4,
input$btn_year, input$btn_country, input$btn_start_year)
sel_country <- country_input[country_input$label == input$btn_country, code]
sel_years <- as.character(as.numeric(input$btn_start_year):as.numeric(input$btn_year))
sel_group_fbs <- as.character(groups_input[label == input$btn_group_fbs_tab4]$code)
sel_ics_prod <- as.character(groups_input[label == input$btn_ics_prod_tab4]$code)
sel_element_sua <- as.character(sua_element_input[ label %in% input$btn_element_sua_tab4]$code)
if(length(sel_element_sua) > 0){
if(nrow(live_data$SUAb) == 0){
if(localrun){
if(CheckDebug()){
library(faoswsModules)
SETTINGS = ReadSettings("sws.yml")
R_SWS_SHARE_PATH = SETTINGS[["share"]]
SetClientFiles(SETTINGS[["certdir"]])
GetTestEnvironment(baseUrl = SETTINGS[["server"]],
token = tokenSuaB)
}
} else {
R_SWS_SHARE_PATH = "Z:"
SetClientFiles("/srv/shiny-server/.R/QA/")
GetTestEnvironment(baseUrl = "https://swsqa.aws.fao.org:8181",
token = tokenSuaB)
}
KeySUAbalElem <- DatasetKey( domain = "FisheriesCommodities",
dataset = "fi_sua_balanced",
dimensions = list(geographicAreaM49_fi = Dimension(name = "geographicAreaM49_fi",
keys = sel_country),
measuredElementSuaFbs = Dimension(name = "measuredElementSuaFbs",
keys = GetCodeList("FisheriesCommodities",
"fi_fbs_fias_control",
"measuredElementSuaFbs" )[,code]),
measuredItemFaostat_L2 = Dimension(name = "measuredItemFaostat_L2",
keys = GetCodeList("FisheriesCommodities",
"fi_sua_balanced_control",
"measuredItemFaostat_L2" )[,code]),
timePointYears = Dimension(name = "timePointYears", keys = sel_years )) )
withProgress(message = 'SUA balanced data loading in progress',
value = 0, {
Sys.sleep(0.25)
incProgress(0.25)
SUAbalElem <- GetData(KeySUAbalElem)
Sys.sleep(0.75)
incProgress(0.95)
})
ValueElements <- c('5922', '5930', '5622', '5630')
SUAbalElemVal <- copy(SUAbalElem)
SUAbalElem <- SUAbalElem[!measuredElementSuaFbs %in% ValueElements]
live_data$SUAb <- SUAbalElem[!measuredElementSuaFbs %in% ValueElements]
live_data$SUAbVal <- SUAbalElemVal[measuredElementSuaFbs %in% ValueElements]
SUAbalElem <- SUAbalElem[measuredElementSuaFbs %in% sel_element_sua & measuredItemFaostat_L2 %in% sel_ics_prod]
SUAbalElem <- rbind(SUAbalElem, SUAbalElemVal[measuredElementSuaFbs %in% sel_element_sua & measuredItemFaostat_L2 %in% sel_ics_prod])
} else {
SUAbalElem <- live_data$SUAb[measuredElementSuaFbs %in% sel_element_sua & measuredItemFaostat_L2 %in% sel_ics_prod]
SUAbalElemVal <- live_data$SUAbVal[measuredElementSuaFbs %in% sel_element_sua & measuredItemFaostat_L2 %in% sel_ics_prod]
SUAbalElem <- rbind(SUAbalElem, SUAbalElemVal)
}
tab2show <- merge(SUAbalElem, l2l1[ , .(code_l1, code_l2)],
by.x = 'measuredItemFaostat_L2', by.y = 'code_l2')
return(tab2show)
}
})
output$sua_elem_tab4 <- DT::renderDataTable( server = FALSE, {
sua_elem_tab_out <- copy(SUAelemTab_reac())
setnames(sua_elem_tab_out, c('geographicAreaM49_fi', 'measuredItemFaostat_L2',
'measuredElementSuaFbs', 'timePointYears',
'flagObservationStatus', 'flagMethod', 'code_l1'),
c('Country', 'ICSprod', 'Element', 'Year', 'F', 'Fm', 'FBSgroup'))
setcolorder(sua_elem_tab_out, c('Country', 'FBSgroup', 'ICSprod', 'Element', 'Year',
'Value', 'F', 'Fm'))
DT::datatable(sua_elem_tab_out, extensions = 'Buttons', filter = 'top',
rownames = FALSE, options = list(pageLength = 25,
dom = 'Bfrtip',
buttons = c('csv', 'excel', 'pdf')))
})
output$gg_plot_tab4 <- renderPlot({
req(input$btn_group_fbs_tab4, input$btn_ics_prod_tab4,
input$btn_year, input$btn_country, input$btn_start_year)
suaElem_data <- copy(SUAelemTab_reac())
# suaElem_data[ ,x_pos := as.numeric(input$btn_year)]
# valuesY <- suaElem_data[timePointYears == as.numeric(input$btn_year), .(measuredElementSuaFbs, Value)]
# setnames(valuesY, 'Value', 'y_pos')
# suaElem_data <- merge(suaElem_data, valuesY, by = 'measuredElementSuaFbs')
# Make grand total
ggplot(data = suaElem_data, aes(x = timePointYears, y = Value)) +
geom_line(aes(group = measuredElementSuaFbs, color = measuredElementSuaFbs), size = 0.7) +
# geom_text(data = suaElem_data[timePointYears == as.numeric(input$btn_year)],
# aes(label = measuredElementSuaFbs, color = measuredElementSuaFbs, check_overlap = TRUE),
# hjust = 0.7, vjust = 1, show_guide = F) +
labs(x = 'Year', color = '') +
theme(text = element_text(size= 15))
})
4.3.6 ‘Global production’ tab
The ‘Global production’ tab load the ‘Global production’ dataset and the corresponding mapping tab for the country and years selected and then filters the data according to the chosen major group.
# Fifth tab, Global production by species tab
gpTab_reac <- reactive({
req(input$btn_group_fbs_tab5,
input$btn_year, input$btn_country, input$btn_start_year)
sel_country <- country_input[country_input$label == input$btn_country, code]
sel_years <- as.character(as.numeric(input$btn_start_year):as.numeric(input$btn_year))
sel_group_fbs <- as.character(groups_input[label %in% input$btn_group_fbs_tab5]$code)
group_sel <- groups_input[ label %in% input$btn_group_fbs_tab5]$code
# ICS product in the chosen FBS group
ICSinput_code <- l2l1[code_l1 %in% sel_group_fbs ]$code_l2
map_asfis_filtered <- map_asfis[ICSProd %in% ICSinput_code]
# -- Get GP data ----
if(nrow(InitialDatasets$GP) == 0){
keyDim <- c("geographicAreaM49_fi", "fisheriesAsfis", "measuredElement", "timePointYears")
KeyGlobal <- DatasetKey(domain = "Fisheries", dataset = "fi_global_production", dimensions = list(
geographicAreaM49_fi = Dimension(name = "geographicAreaM49_fi", keys = sel_country),
fisheriesAsfis = Dimension(name = "fisheriesAsfis", keys = GetCodeList("Fisheries", "fi_global_production","fisheriesAsfis" )[,code]),
fisheriesCatchArea = Dimension(name = "fisheriesCatchArea", keys = GetCodeList("Fisheries", "fi_global_production","fisheriesCatchArea" )[,code]),
measuredElement = Dimension(name = "measuredElement", keys = c("FI_001")),
timePointYears = Dimension(name = "timePointYears", keys = sel_years)))
withProgress(message = 'Global production data loading in progress',
value = 0, {
Sys.sleep(0.25)
incProgress(0.25)
globalProduction <- GetData(KeyGlobal)
Sys.sleep(0.75)
incProgress(0.95)
})
InitialDatasets$GP <- globalProduction
} else {
globalProduction <- InitialDatasets$GP
}
# Aggregate by fisheriesCatchArea
# Convert flags into ordinal factor so that simple aggregation is possible
# The function aggregateObservationFlag is too slow so flag are transformed into factors
globalProduction <- globalProduction[fisheriesAsfis %in% map_asfis_filtered$fisheriesAsfis]
globalProduction$flagObservationStatus <- factor(globalProduction$flagObservationStatus,
levels = c('M', 'O', 'N', '', 'X', 'T', 'E', 'I'),
ordered = TRUE)
globalProduction <- globalProduction[ , list(ValueAggr = sum(Value, na.rm = TRUE),
flagObservationStatusAggr = max(flagObservationStatus),
flagMethodAggr = "s"),
by=c("geographicAreaM49_fi",
"fisheriesAsfis",
"measuredElement",
"timePointYears")]
setnames(globalProduction, names(globalProduction), c("geographicAreaM49_fi", "fisheriesAsfis",
"measuredElement", "timePointYears",
"Value", "flagObservationStatus",
"flagMethod"))
# -- Process GP data ----
# Hard code change from FI_001 to 5510, both are Production in tonnes.
globalProduction <- globalProduction[ , measuredElement := "5510"]
globalProductionIcs <- merge(globalProduction, map_asfis_filtered, by = c("fisheriesAsfis"))
globalProductionMapping <- merge(globalProductionIcs, l2l1[ , .(code_l1, code_l2)],
by.x = 'ICSProd', by.y = 'code_l2')
# globalProductionMapping[ , c('Ratio', 'Selection') := list(1, TRUE)]
# gp_map <- ReadDatatable('gp_mapping', where = paste("country = '", sel_country, "'", sep = ''))#data.table(Country = '', Asfis = '', from = '', to = '', start = '', end = '', ratio = '')
#
# if(nrow(gp_map) == 0 ){
#
# gp_map <- data.table(country = sel_country, asfis = '',
# from_code = '', to_code = '',
# start_year = input$btn_year, end_year = 'LAST', ratio = '1')
# }
validate(need(nrow(globalProductionMapping) >0,
'No GP data to show.'))
return(list(GP = globalProductionMapping))
})
output$gp_tab5 <- DT::renderDataTable( server = FALSE, {
gp_tab <- copy(gpTab_reac()$GP)
validate(need(nrow(gp_tab) >0,
'No GP data to show.'))
setnames(gp_tab, c("geographicAreaM49_fi", "fisheriesAsfis",
"timePointYears",
"flagObservationStatus",
"flagMethod", "code_l1"),
c('Country', 'Species', 'Year', 'F1', 'F2', 'FBSgroup'))
gp_tab_out <- dcast(gp_tab, Country + FBSgroup + ICSProd + description + Species ~ Year, value.var = c("Value"))
# Deleted: + Selection + Ratio
# rhandsontable(gp_tab_out, rowHeaders = NULL, width = 'auto', height = 'auto')
DT::datatable(gp_tab_out, extensions = 'Buttons', filter = 'top',
rownames = FALSE, options = list(pageLength = 25,
dom = 'Bfrtip',
buttons = c('csv', 'excel', 'pdf')))
})
gpMap_reac <- reactive({
req(input$btn_country)
sel_country <- country_input[country_input$label == input$btn_country, code]
gp_map <- ReadDatatable('gp_mapping', where = paste("country = '", sel_country, "'", sep = ''))#data.table(Country = '', Asfis = '', from = '', to = '', start = '', end = '', ratio = '')
updated_mappings$GP <- gp_map
if(nrow(gp_map) == 0 ){
gp_map <- data.table(country = sel_country, asfis = '',
from_code = '', to_code = '',
start_year = input$btn_year, end_year = 'LAST', ratio = '1')
}
return(list(newMap = gp_map))
})
The mapping table is also loaded for the chosen country and the save buttons modifies the data table directly in SWS adding the links the user put.
output$gp_map_tab5 <- renderRHandsontable({
gp_map <- gpMap_reac()$newMap
rhandsontable(gp_map, rowHeaders = NULL, width = 'auto', height = 'auto')
})
observeEvent(input$saveGP, {
sel_country <- country_input[country_input$label == input$btn_country, code]
new_map <- rhandsontable::hot_to_r(input$gp_map_tab5)
updated_mappings$GP <- new_map
gp_map <- ReadDatatable('gp_mapping',
where = paste("country = '", sel_country, "'", sep = ''),
readOnly = F)
changesetGP <- Changeset('gp_mapping')
# Add rows to delete to changeset
AddDeletions(changesetGP, gp_map)
# Send modifications to the server
Finalise(changesetGP)
# Add new data (twice) to test from original
AddInsertions(changesetGP, new_map)
Finalise(changesetGP)
showModal(modalDialog(
title = "GP mapping changed!" ,
sprintf("The new mapping will be used in the validation tab.")
))
})
4.3.7 ‘Commodities’ tab
The tab for the Commodity dataset is similar to the ‘Global production’ tab but the user can choose the ICS product code in addition to the major group and also the elements can be filtered. The command to save the changes to the ISSCFC deviations are the same as for the ‘Global production’ tab.
# Sixth tab, trade by commodity tab
cdbTab_reac <- reactive({
req(input$btn_ics_prod_tab6, input$btn_element_cdb_tab6,
input$btn_country, input$btn_year, input$btn_start_year)
sel_country <- country_input[country_input$label == input$btn_country, code]
sel_years <- as.character(as.numeric(input$btn_start_year):as.numeric(input$btn_year))
sel_ics_prod <- as.character(groups_input[label %in% input$btn_ics_prod_tab6]$code)
sel_element_cdb <- as.character(sua_element_input[ label %in% input$btn_element_cdb_tab6]$code)
# ICS product in the chosen FBS group
map_isscfc_filtered <- map_isscfc[ICSProd %in% sel_ics_prod]
# -- Get CDB data ----
if(nrow(InitialDatasets$CDB) == 0){
KeyComm <- DatasetKey(domain = "Fisheries Commodities", dataset = "commodities_total", dimensions = list(
geographicAreaM49_fi = Dimension(name = "geographicAreaM49_fi", keys = sel_country),
measuredItemISSCFC = Dimension(name = "measuredItemISSCFC",
keys = GetCodeList("FisheriesCommodities", "commodities_total","measuredItemISSCFC" )[,code]),
measuredElement = Dimension(name = "measuredElement",
keys = GetCodeList("FisheriesCommodities", "commodities_total","measuredElement" )[,code]),
timePointYears = Dimension(name = "timePointYears", keys = sel_years)))
withProgress(message = 'Commodity data loading in progress',
value = 0, {
Sys.sleep(0.25)
incProgress(0.25)
commodityDB <- GetData(KeyComm)
Sys.sleep(0.75)
incProgress(0.95)
})
commodityDB$flagObservationStatus <- factor(commodityDB$flagObservationStatus,
levels = c('M', 'O', 'N', '', 'X', 'T', 'E', 'I'),
ordered = TRUE)
# Re-export in Export (quantity and values)
commodityDB[measuredElement == '5912', measuredElement := '5910'] # quantity
commodityDB[measuredElement == '5923', measuredElement := '5922'] # Value in 1000$
commodityDB[measuredElement == '5931', measuredElement := '5930'] # Unit value $/t
commodityDB <- commodityDB[!measuredElement %in% c('5907', '5937',
'5607', '5637',
'5906', '5940')]
# Isolate prices (not entering all the processing)
ValueElements <- c('5922', '5930', '5622', '5630')
commodityDBValue <- commodityDB[measuredElement %in% ValueElements]
commodityDB <- commodityDB[!measuredElement %in% ValueElements]
InitialDatasets$CDB <- commodityDB
InitialDatasets$CDBVal <- commodityDBValue
} else {
commodityDB <- InitialDatasets$CDB
commodityDBValue <- InitialDatasets$CDBVal
}
commodityDB <- rbind(commodityDB, commodityDBValue)
commodityDB <- commodityDB[measuredItemISSCFC %in% map_isscfc_filtered$measuredItemISSCFC & measuredElement %in% sel_element_cdb]
commodityDB$flagObservationStatus <- factor(commodityDB$flagObservationStatus,
levels = c('M', 'O', 'N', '', 'X', 'T', 'E', 'I'),
ordered = TRUE)
commodityDBIcs <- merge(commodityDB, map_isscfc_filtered, by = "measuredItemISSCFC")
commodityDBIcs$measuredItemISSCFC <- as.character(commodityDBIcs$measuredItemISSCFC)
commodityDBMapping <- merge(commodityDBIcs, l2l1[ , .(code_l1, code_l2)],
by.x = 'ICSProd', by.y = 'code_l2')
# commodityDBMapping[ , c('Ratio', 'Selection') := list(1, TRUE)]
isscfc_dim <- GetCodeList(domain = 'FisheriesCommodities', dataset = 'commodities_total',
dimension = "measuredItemISSCFC", codes = map_isscfc_filtered$measuredItemISSCFC)[ , .(code, description)]
cdbDescr <- merge(commodityDBMapping, isscfc_dim, by.x = 'measuredItemISSCFC', by.y = 'code')
setnames(cdbDescr, c("geographicAreaM49_fi", "measuredItemISSCFC",
"timePointYears", "measuredElement",
"flagObservationStatus",
"flagMethod", "code_l1"),
c('Country', 'ISSCFC', 'Year', 'Element', 'F1', 'F2', 'FBSgroup'))
# -- Process CDB data ----
# cdb_map <- ReadDatatable('cdb_mapping', where = paste("country = '", sel_country, "'", sep = '')) #data.table(Country = '', Isscfc = '', Element = '', from = '', to = '', start = '', end = '', ratio = '')
#
# if(nrow(cdb_map) == 0 ){
#
# cdb_map <- data.table(country = sel_country, isscfc = '', element = '',
# from_code = '', to_code = '',
# start_year = input$btn_year, end_year = 'LAST', ratio = '1')
# }
#
return(list(CDB = cdbDescr))
})
output$cdb_tab6 <- DT::renderDataTable( server = FALSE, {
if(is.null(cdbTab_reac()$CDB)) return(NULL)
if(is.null(input$btn_ics_prod_tab6)) return(NULL)
cdb_tab <- copy(cdbTab_reac()$CDB)
cdb_tab <- cdb_tab[ , .(Country, FBSgroup, ICSProd, description, ISSCFC, Element, Year, Value)]
if(nrow(cdb_tab) > 0){
cdb_tab_out <- dcast(cdb_tab, Country + FBSgroup + ICSProd + description + ISSCFC + Element ~ Year, value.var = c("Value"))
} else {cdb_tab_out <- data.table()}
# Deleted:+ Ratio + Selection
# rhandsontable(cdb_tab_out, rowHeaders = NULL, width = 'auto', height = 'auto')
DT::datatable(cdb_tab_out, extensions = 'Buttons', filter = 'top',
rownames = FALSE, options = list(pageLength = 25,
dom = 'Bfrtip',
buttons = c('csv', 'excel', 'pdf')))
})
cdbMap_reac <- reactive({
req(input$btn_country)
sel_country <- country_input[country_input$label == input$btn_country, code]
cdb_map <- ReadDatatable('cdb_mapping', where = paste("country = '", sel_country, "'", sep = '')) #data.table(Country = '', Isscfc = '', Element = '', from = '', to = '', start = '', end = '', ratio = '')
if(nrow(cdb_map) == 0 ){
cdb_map <- data.table(country = sel_country, isscfc = '', element = '',
from_code = '', to_code = '',
start_year = input$btn_year, end_year = 'LAST', ratio = '1')
}
return(list(newMapCDB = cdb_map))
})
output$cdb_map_tab6 <- renderRHandsontable({
cdb_map <- copy(cdbMap_reac()$newMapCDB)
rhandsontable(cdb_map, rowHeaders = NULL, width = 'auto', height = 'auto')
})
observeEvent(input$cdb_map_tab6 ,{
new_map <- rhandsontable::hot_to_r(input$cdb_map_tab6)
updated_mappings$CDB <- new_map
})
observeEvent(input$saveCDB, {
sel_country <- country_input[country_input$label == input$btn_country, code]
new_map <- rhandsontable::hot_to_r(input$cdb_map_tab6)
updated_mappings$CDB <- new_map
cdb_map <- ReadDatatable('cdb_mapping', where = paste("country = '", sel_country, "'", sep = ''), readOnly = F)
changeset <- Changeset('cdb_mapping')
# Add rows to delete to changeset
AddDeletions(changeset, cdb_map)
# Send modifications to the server
Finalise(changeset)
# Add new data (twice) to test from original
AddInsertions(changeset, new_map)
Finalise(changeset)
showModal(modalDialog(
title = "CDB mapping changed!" ,
sprintf("The new mapping will be used in the validation tab.")
))
})
4.3.8 ‘Link table’ tab
The ‘Link table’ tab is very simple, it pulls the SWS data table link_table and updates it when the user click the ‘Update table button’.
# link table recall
linktable_reac <- reactive({
req(input$btn_year, input$btn_country, input$btn_start_year)
sel_country <- country_input[country_input$label == input$btn_country, code]
where <- paste("geographic_area_m49 = '", sel_country, "'", sep = "")
linktable <- ReadDatatable('link_table', where = where, readOnly = FALSE)
linktable$percentage <- as.numeric(linktable$percentage)
if(nrow(linktable) == 0){
linktable <- rbind(linktable, data.table(geographic_area_m49 =sel_country),
fill = T)
}
return(linktable)
})
output$linktable <- renderRHandsontable({
table <- linktable_reac()
table$percentage <- as.numeric(table$percentage)
rhandsontable(table,
rowHeaders = NULL, width = 'auto', height = 'auto') %>%
hot_col(c("__id", "__ts"), colWidths = c(rep(0.1,2),rep(150,7)), readOnly = TRUE)
})
observeEvent(input$updLT, {
updLinkTable <- rhandsontable::hot_to_r(input$linktable)
updLinkTable <- as.data.table(updLinkTable)
if(any(!updLinkTable$flow %in% c('EXP', 'IMP', 'PRD', 'ALL', 'TRD'))){
showModal(modalDialog(
title = "Error!" ,
sprintf("Flow must belong to one of these options:
'EXP', 'IMP', 'PRD', 'ALL', 'TRD'")
))
} else {
changeset <- Changeset('link_table')
AddModifications(changeset, updLinkTable)
Finalise(changeset)
showModal(modalDialog(
title = "Link table updated." ,
sprintf("The new version of the link table is now available on the SWS.")
))
}
})
4.3.9 ‘Balancing elements’ tab
The ‘Balancing elements’ tab replicates the functioning of the ‘Link table’ tab but with the balancing_elements SWS data table.
# link table recall
baltable_reac <- reactive({
req(input$btn_year, input$btn_country, input$btn_start_year)
sel_country <- country_input[country_input$label == input$btn_country, code]
where <- paste("geographic_area_m49_fi = '", sel_country, "'", sep = "")
baltable <- ReadDatatable('balancing_elements', where = where, readOnly = FALSE)
if(nrow(baltable) == 0){
baltable <- rbind(baltable, data.table(geographic_area_m49_fi =sel_country),
fill = T)
}
return(baltable)
})
output$balancingelements <- renderRHandsontable({
table <- baltable_reac()
rhandsontable(table,
rowHeaders = NULL, width = 'auto', height = 'auto') %>%
hot_col(c("__id", "__ts"), colWidths = c(rep(0.1,2),rep(150,6)), readOnly = TRUE)
})
observeEvent(input$updBal, {
updbalTable <- rhandsontable::hot_to_r(input$balancingelements)
changeset <- Changeset('balancing_elements')
AddModifications(changeset, updbalTable)
Finalise(changeset)
showModal(modalDialog(
title = "Balancing element table updated." ,
sprintf("The new version of is now available on the SWS.")
))
})
4.3.10 ‘Extraction rates’ tab
In the ‘reactive’ function the extraction rate data are pulled either from the SUA balanced or directly from the SWS. The data are the showed into a table in the tab the user can modify.
# Extraction rates tab
extrR_reac <- reactive({
sel_country <- country_input[country_input$label == input$btn_country, code]
sel_years <- as.character(as.numeric(input$btn_start_year):as.numeric(input$btn_year))
if(nrow(live_data$SUAb) == 0){
if(localrun){
if(CheckDebug()){
library(faoswsModules)
SETTINGS = ReadSettings("sws.yml")
R_SWS_SHARE_PATH = SETTINGS[["share"]]
SetClientFiles(SETTINGS[["certdir"]])
GetTestEnvironment(baseUrl = SETTINGS[["server"]],
token = tokenSuaB)
}
} else {
R_SWS_SHARE_PATH = "Z:"
SetClientFiles("/srv/shiny-server/.R/QA/")
GetTestEnvironment(baseUrl = "https://swsqa.aws.fao.org:8181",
token = tokenSuaB)
}
KeySUAbal <- DatasetKey(domain = "FisheriesCommodities", dataset = "fi_sua_balanced", dimensions = list(
geographicAreaM49_fi = Dimension(name = "geographicAreaM49_fi", keys = sel_country),
measuredElementSuaFbs = Dimension(name = "measuredElementSuaFbs",
keys = '5423'),
measuredItemFaostat_L2 = Dimension(name = "measuredItemFaostat_L2",
keys = GetCodeList("FisheriesCommodities", "fi_sua_balanced","measuredItemFaostat_L2" )[,code]),
timePointYears = Dimension(name = "timePointYears", keys = sel_years )))
withProgress(message = 'Extraction rate data loading in progress',
value = 0, {
Sys.sleep(0.25)
incProgress(0.25)
SUAbalEr <- GetData(KeySUAbal)
Sys.sleep(0.75)
incProgress(0.95)
})
} else {
SUAbalEr <- live_data$SUAb
SUAbalEr <- SUAbalEr[measuredElementSuaFbs == '5423']
}
if(nrow(SUAbalEr) == 0){
ny <- length(sel_years)
SUAbalEr <- rbind(SUAbalEr, data.table(geographicAreaM49_fi = rep(sel_country, ny),
measuredElementSuaFbs = rep('5423', ny),
timePointYears = sel_years,
flagObservationStatus = rep('E', ny),
flagMethod = rep('f', ny)),
fill = T)
}
return(SUAbalEr)
})
output$extrR <- renderRHandsontable({
table <- extrR_reac()
rhandsontable(table, rowHeaders = NULL, width = 'auto', height = 'auto', digits = 6)
})
In order to store the modification a reactiveValue object is created (new_extr_rate) and will be used in the re-processing calculations. Before updating the extraction rates, the user has to choose the type of change to perform: a single year change or a series change. In both cases, when the user presses the ‘Update’ button, the original extraction rates data are pulled from the SWS and compared with the modified table. Also the number of changes is calculated.
If the the single year update is chosen, the code merges the old and the new table and updates the table creating the object eRupd. If the user chose the ‘update series’ button, the code acts differently if the number of updates or equal or greater than one. First of all, if this second option is chosen, the codes assumes only one value has to be assigned to the whole series and therefore the user cannot change more than one value for each ICS product. If only one rate is changed the code updates the correspondent series otherwise it will update the series product by product with a ‘for’ cycle. The new rates are stored into the new_extr_rate object and a message appears notifying the correct update.
The extraction rates can be checked and updated in this table or in the ‘Data validation’ one. This tab is advisable when performing series changes whereas the single year ones can be done in the other tab.
new_extr_rate <- reactiveValues(eR = data.table())
observeEvent(input$updER, {
sel_country <- country_input[country_input$label == input$btn_country, code]
sel_years <- as.character(as.numeric(input$btn_start_year):as.numeric(input$btn_year))
if(localrun){
if(CheckDebug()){
library(faoswsModules)
SETTINGS = ReadSettings("sws.yml")
R_SWS_SHARE_PATH = SETTINGS[["share"]]
SetClientFiles(SETTINGS[["certdir"]])
GetTestEnvironment(baseUrl = SETTINGS[["server"]],
token = tokenSuaB)
}
} else {
R_SWS_SHARE_PATH = "Z:"
SetClientFiles("/srv/shiny-server/.R/QA/")
GetTestEnvironment(baseUrl = "https://swsqa.aws.fao.org:8181",
token = tokenSuaB)
}
KeySUAbal <- DatasetKey(domain = "FisheriesCommodities", dataset = "fi_sua_balanced", dimensions = list(
geographicAreaM49_fi = Dimension(name = "geographicAreaM49_fi", keys = sel_country),
measuredElementSuaFbs = Dimension(name = "measuredElementSuaFbs",
keys = '5423'),
measuredItemFaostat_L2 = Dimension(name = "measuredItemFaostat_L2",
keys = GetCodeList("FisheriesCommodities", "fi_sua_balanced","measuredItemFaostat_L2" )[,code]),
timePointYears = Dimension(name = "timePointYears", keys = sel_years )))
SUAbalEr <- GetData(KeySUAbal)
# copy to compare tables with right decimals number
SUAbalErComp <- copy(SUAbalEr)
SUAbalErComp$Value <- round(SUAbalErComp$Value,2)
updER <- rhandsontable::hot_to_r(input$extrR)
if(nrow(SUAbalErComp) > 0){
changed <- length(updER[Value != SUAbalErComp$Value, ]$Value)
newValue <- updER[Value != SUAbalErComp$Value, ]
# Radio button for the update type
if(input$radioErUpdt == 1){
eRupd <- merge(SUAbalEr, newValue, by = c('geographicAreaM49_fi', 'measuredElementSuaFbs',
'measuredItemFaostat_L2', 'timePointYears'),
all = TRUE, suffixes = c('Old', 'New'))
eRupd[!is.na(ValueNew) | ValueNew != ValueOld, c('ValueOld',
'flagObservationStatusOld',
'flagMethodOld') := list(ValueNew, 'E', 'f')]
setnames(eRupd, c('ValueOld',
'flagObservationStatusOld',
'flagMethodOld'),
c('Value',
'flagObservationStatus',
'flagMethod'))
eRupd <- eRupd[ , c('ValueNew',
'flagObservationStatusNew',
'flagMethodNew') := NULL]
# Not good for the decimal problem
#eRupd <- SUAbalEr[Value != updER$Value, c("Value",
# "flagObservationStatus",
# "flagMethod"):= list(updER[Value != SUAbalEr$Value, ]$Value, 'E', 'f')]
showModal(modalDialog(
title = "Extraction rates updated." ,
sprintf("The new figures have been saved.")
))
} else if(input$radioErUpdt == 2) {
if(changed == 1){
eRupd <- SUAbalEr[timePointYears %in% sel_years &
measuredItemFaostat_L2 %in% newValue$measuredItemFaostat_L2,
c('Value', 'flagObservationStatus', 'flagMethod') := list(newValue$Value, 'E', 'f')]
} else if (changed > 1){
for(i in 1:changed){
eRupd <- SUAbalEr
eRupd <- eRupd[timePointYears %in% sel_years &
measuredItemFaostat_L2 %in% newValue$measuredItemFaostat_L2[i],
c('Value', 'flagObservationStatus', 'flagMethod') := list(newValue$Value[i], 'E', 'f')]
}
}
showModal(modalDialog(
title = "Extraction rates updated." ,
sprintf("The new figures have been saved.")
))
}
} else {
if(input$radioErUpdt == 1){
eRupd <- updER[!is.na(Value)]
} else if(input$radioErUpdt == 2) {
eRupd <- updER[rep(seq_len(nrow(updER[!is.na(Value)])), each = length(sel_years)), ]
for(i in unique(eRupd$measuredItemFaostat_L2)){
eRupd[measuredItemFaostat_L2 == i]$timePointYears <- sel_years
}
}
showModal(modalDialog(
title = "Extraction rates updated." ,
sprintf("The new figures have been saved.")
))
}
new_extr_rate$eR <- eRupd[timePointYears %in% sel_years]
# SaveData(domain = "FisheriesCommodities", dataset = "fi_sua_balanced", data = compare)
})
4.3.11 ‘Data validation’ tab
This tab contains all the possible combination of re-processing operations. The first lines of the file contain the object to store the different version of the SUA: the initial version (or the latest recalculated one), the latest modified one and the uploaded one (if a .csv file has been uploaded). A simple ‘workaround’ object is created to notify if a recalculation has already been performed since the launch of the shiny.
The SUA table shown in the tab is the result of the last SUA balanced update and filtered according to the major group, ICS product and element buttons. Hence the code checks:
if the SUA balanced has been initially loaded or not yet and if not loads it
if there is an updated version to use and if so use the most updated one
If new extraction rates have been stored and, if available, uses them (the extraction rates can also be changed directly in this table)
The table is prepared and a message appears if no data is available for the data combination.
# Data validation tab
recalc_value <- reactiveValues(SUAinit = data.table(),
SUAmodtab = data.table(),
SUAupload = data.table())
workaround <- reactiveValues(V = 0)
# -- SUA reactive ----
# Tab to show and modify
suaTab_reac <- reactive({
req(input$btn_group_fbs_tab7, input$btn_ics_prod_tab7, input$btn_sua_elem_tab7,
input$btn_country, input$btn_year, input$btn_start_year)
sel_country <- country_input[country_input$label == input$btn_country, code]
sel_years <- as.character(as.numeric(input$btn_start_year):as.numeric(input$btn_year))
sel_group_fbs <- as.character(groups_input[label %in% input$btn_group_fbs_tab7]$code)
sel_ics <- input$btn_ics_prod_tab7
if('All' %in% sel_ics){
sel_ics_prod <- as.character(l2l1[code_l1 %in% sel_group_fbs ]$code_l2)
} else {
sel_ics_prod <- as.character(groups_input[label %in% sel_ics]$code)
}
sel_element_sua <- as.character(sua_element_input[ label %in% input$btn_sua_elem_tab7]$code)
if(nrow(recalc_value$SUAmodtab) == 0){
# load SUA balanced if needed
SUA0 <- reloadDataToken(data = live_data$SUAb,
keycountry = sel_country,
minyear = input$btn_start_year,
maxyear = input$btn_year,
keydomain = domainComm,
keydataset = datasetSUABlive,
keytoken = tokenSuaB)
if(!is.null(SUA0)){
ValueElements <- c('5922', '5930', '5622', '5630')
liveBval <- copy(SUA0)
liveBval <- liveBval[measuredElementSuaFbs %in% ValueElements]
live_data$SUAbVal <- liveBval
# SUA0 <- SUA0[!measuredElementSuaFbs %in% ValueElements]
live_data$SUAb <- SUA0
recalc_value$SUAinit <- SUA0
if(nrow(live_data$SUAb) == 0){
showModal(modalDialog(
title = "No SUA data for this country. ",
sprintf('Please select another country.')
))
}
} else {
if(nrow(live_data$SUAb) == 0){
showModal(modalDialog(
title = "No SUA data for this country. ",
sprintf('Please select another country.')
))
}
SUA0 <- live_data$SUAb
recalc_value$SUAinit <- live_data$SUAb
}
SUA <- SUA0[measuredItemFaostat_L2 %in% sel_ics_prod & measuredElementSuaFbs %in% sel_element_sua , ]
} else {
if(unique(recalc_value$SUAmodtab$geographicAreaM49) == sel_country){
SUA0 <- recalc_value$SUAmodtab
SUA <- SUA0[geographicAreaM49_fi == sel_country &
measuredElementSuaFbs %in% sel_element_sua &
measuredItemFaostat_L2 %in% sel_ics_prod &
timePointYears %in% sel_years, ]
} else{
SUA0 <- reloadDataToken(data = live_data$SUAb,
keycountry = sel_country,
minyear = input$btn_start_year,
maxyear = input$btn_year,
keydomain = domainComm,
keydataset = datasetSUABlive,
keytoken = tokenSuaB)
if(!is.null(SUA0)){
ValueElements <- c('5922', '5930', '5622', '5630')
liveBval <- copy(SUA0)
liveBval <- liveBval[measuredElementSuaFbs %in% ValueElements]
live_data$SUAbVal <- liveBval
# SUA0 <- SUA0[!measuredElementSuaFbs %in% ValueElements]
live_data$SUAb <- SUA0
recalc_value$SUAinit <- SUA0
if(nrow(live_data$SUAb) == 0){
showModal(modalDialog(
title = "No SUA data for this country. ",
sprintf('Please select another country.')
))
}
} else {
if(nrow(live_data$SUAb) == 0){
showModal(modalDialog(
title = "No SUA data for this country. ",
sprintf('Please select another country.')
))
}
SUA0 <- live_data$SUAb
recalc_value$SUAinit <- live_data$SUAb
}
SUA <- SUA0[measuredItemFaostat_L2 %in% sel_ics_prod & measuredElementSuaFbs %in% sel_element_sua , ]
}
}
tab2show <- merge(SUA, l2l1[ , .(code_l1, code_l2)],
by.x = 'measuredItemFaostat_L2', by.y = 'code_l2')
# browser()
if(nrow(new_extr_rate$eR) > 0){
updER <- new_extr_rate$eR
for(i in 1:nrow(updER)){
updER[i , code_l1 := l2l1[code_l2 == updER[i,]$measuredItemFaostat_L2]$code_l1 ]
}
if(nrow(tab2show[measuredElementSuaFbs == '5423',]) > 0){ # == nrow(updER)){
Er <- merge(tab2show[measuredElementSuaFbs == '5423',], updER,
by = c('geographicAreaM49_fi', 'measuredItemFaostat_L2',
'measuredElementSuaFbs', 'timePointYears',
'code_l1'), all = T, suffixes = c('', 'Upd'))
Er[is.na(Value), Value := ValueUpd ]
Er[!is.na(ValueUpd) & !is.na(Value) & Value != ValueUpd, Value := ValueUpd ]
Er[, c("ValueUpd",
"flagObservationStatusUpd",
"flagMethodUpd") := NULL]
tab2show <- rbind(tab2show[measuredElementSuaFbs != '5423',], Er[measuredItemFaostat_L2 %in% sel_ics_prod & timePointYears %in% sel_years])
# tab2show[measuredElementSuaFbs == '5423', c("Value",
# "flagMethod"):= list(updER$Value, updER$flagMethod)]
} else {
tab2show <- rbind(tab2show[measuredElementSuaFbs != '5423',], updER[measuredItemFaostat_L2 %in% sel_ics_prod & timePointYears %in% sel_years])
# rbind(tab2show, updER[measuredItemFaostat_L2 %in% sel_ics_prod & timePointYears %in% sel_years])
}
}
setnames(tab2show, c('geographicAreaM49_fi', 'measuredItemFaostat_L2',
'measuredElementSuaFbs', 'timePointYears',
'flagObservationStatus', 'flagMethod', 'code_l1'),
c('Country', 'ICSprod', 'Element', 'Year', 'F', 'Fm', 'FBSgroup'))
tab2show <- merge(tab2show, SUAelements[ , .(code, idx)], by.x = 'Element',
by.y = 'code', all.x = TRUE)
tab2show <- tab2show[order(as.numeric(idx)),]
# tab2show[ , official := ifelse(F1 == '', 1, -1)]
# sua_tab <- sua_tab[ , idx := NULL]
validate(need(
nrow(tab2show) > 0,
'No data to show for this product.'
))
sua_tab_out <- dcast(tab2show, Country + FBSgroup + ICSprod + idx + Element ~ Year, value.var = c("Value", "F"))
colflag <- c((ncol(sua_tab_out) - (ncol(sua_tab_out) -5)/2 + 1):ncol(sua_tab_out))
colvalue <- c(6:((ncol(sua_tab_out) -5)/2 + 5))
colorder <- as.vector(matrix(c(colvalue, colflag), nrow = 2, byrow = TRUE))
neworder <- c(names(sua_tab_out)[1:5], names(sua_tab_out)[colorder])
setcolorder(sua_tab_out, neworder)
setnames(sua_tab_out, names(sua_tab_out), sub("Value_", "", names(sua_tab_out)))
return(list(sua2show = sua_tab_out[ , idx := NULL]))
})
# -- SUA renderRHandsontable ----
output$sua_tab7 <- renderRHandsontable({
req(input$btn_group_fbs_tab7, input$btn_ics_prod_tab7, input$btn_sua_elem_tab7,
input$btn_country, input$btn_year, input$btn_start_year)
sel_country <- country_input[country_input$label == input$btn_country, code]
sua_tab_out <- suaTab_reac()$sua2show
validate(need(
nrow(sua_tab_out) > 0,
'No data to show for this product.'
))
col2hide <- seq(6, ncol(sua_tab_out), by = 2)
colvalue <- seq(5, ncol(sua_tab_out) - 1, by = 2)
rhandsontable(sua_tab_out, rowHeaders = NULL, width = 'auto', height = 'auto', digits = 6) %>%
hot_cols(fixedColumnsLeft = 4) # number of columns to freeze = 4
# , renderer = "
# function (instance, td, row, col, prop, value, cellProperties) {
# Handsontable.renderers.NumericRenderer.apply(this, arguments);
# if (value == '') {
# td.style.background = 'lightgreen';
# }
# }"
# )
})
The availability table just below the SUA is now built using the same formula as in the plugin, i.e. using the element_sign_table data table. The availability table is reactive and only considers the selected elements, i.e. the results should be zero if the SUA is balanced and all the SUA elements are selected.
# -- Availability table ----
output$textAv <- renderText({
req(input$btn_group_fbs_tab7,
input$btn_ics_prod_tab7, input$btn_country, input$btn_year, input$btn_start_year)
"Availability table:"
})
output$availability <- renderRHandsontable({
req(input$btn_country, input$btn_year, input$btn_start_year,input$btn_group_fbs_tab7,
input$btn_ics_prod_tab7)
if(is.null(input$sua_tab7)) return(NULL)
tab_updated <- rhandsontable::hot_to_r(input$sua_tab7)
tab_updated <- tab_updated[ , -grep("F_", colnames(tab_updated)), with = FALSE ]
tab2calc <- melt(tab_updated, id.vars = c('Country', 'ICSprod', 'Element', 'FBSgroup'),
measure.vars = names(tab_updated)[!names(tab_updated) %in% c('Country', 'ICSprod', 'Element', 'FBSgroup', 'sign')],
variable.name = 'Year', value.name = 'Value')
elementSignTable <- ReadDatatable('element_sign_table')
# Now only considering production, import and export to compute availability
# then after calculations we compare official food processing data with calculations
# Actually not expanded
sua_avail <- merge(tab2calc, elementSignTable[ , .(measured_element, sign)],
by.x = 'Element', by.y = "measured_element", all.x = TRUE)
sua_avail <- sua_avail[, availability := round(sum(Value * sign, na.rm = TRUE), 3),
by = list(Country, FBSgroup, ICSprod, Year)]
sua_avail[ , c('Element', 'Value', 'sign') := NULL]
setkey(sua_avail)
avail2show <- unique(sua_avail)
avail2show <- dcast(avail2show, Country + FBSgroup + ICSprod ~ Year, value.var = c("availability"))
rhandsontable(avail2show, rowHeaders = NULL, width = 'auto', height = 'auto', digits = 6) # %>%
# hot_col('availability', renderer = 'green')
})
This next chunk correspond to the upload and the download buttons in the tab. The code is simple as no additional operation is expected. The shiny download the table on the tab tel-quel and upload the file tel-quel it is then important not to modify the column structure of the downloaded file.
# -- Upload/Download ----
output$contents <- renderTable({
inFile <- input$updatedSUA
if (is.null(inFile))
return(NULL)
# req(input$updatedSUA)
tryCatch(
{
df <- read.csv(inFile$datapath,
header = TRUE,
colClasses = "character"#input$header #,
# sep = input$sep,
# quote = input$quote
)
},
error = function(e) {
# return a safeError if a parsing error occurs
stop(safeError(e))
}
)
validate(need(nrow(df) > 1,
'Empty file uploaded.'))
recalc_value$SUAupload <- df
return(df)
})
output$downloadData <- downloadHandler(
filename = function() {
paste("EditedTable-", Sys.Date(), ".csv", sep="")
},
# what should go in place of table
content = function(file) {
table <- suaTab_reac()$sua2show
table <- table[ , -grep("F_", colnames(table)), with = FALSE ]
write.csv(table, file, row.names = FALSE)
}
)
The food processing results stored into the files by the plugin are now displayed in this tab in different tab depending in the level of food processing unbalance. The structure of the code is the same for each part. The stored object is recalled and displayed in a different table. These tables are not updated by the shiny the user has now the complete control of all the imbalances and it is assumed that the user is fixing all the unbalances there is therefore no need to re-update these auxiliary files. In order to not delete all controls the imbalance data tables in SWS will be updated.
# -- FP Feedback ----
feedback <- reactiveValues(FP = list())
output$FPtab1 <- DT::renderDataTable( server = FALSE, {
req(input$btn_group_fbs_tab7, input$btn_ics_prod_tab7, input$btn_sua_elem_tab7,
input$btn_country, input$btn_year, input$btn_start_year)
# feedback$FP <- FPfile
tab1 <- FPfile$primary # feedback$FP$primary$tab
sel_country <- country_input[country_input$label == input$btn_country, code]
if(nrow(tab1) > 0){
tab1$value <- round(tab1$value,3)
DT::datatable(tab1[geographicaream49_fi == sel_country], extensions = 'Buttons', filter = 'top',
rownames = FALSE, options = list(pageLength = 25,
dom = 'Bfrtip',
buttons = c('csv', 'excel', 'pdf')))
} else {
DT::datatable(data.table(), extensions = 'Buttons', filter = 'top',
rownames = FALSE, options = list(pageLength = 25,
dom = 'Bfrtip',
buttons = c('csv', 'excel', 'pdf')))
}
})
output$FPinsuff <- DT::renderDataTable( server = FALSE, {
req(input$btn_group_fbs_tab7, input$btn_ics_prod_tab7, input$btn_sua_elem_tab7,
input$btn_country, input$btn_year, input$btn_start_year)
#feedback$FP <- FPfile
tab1 <- FPfile$secondaryTot # feedback$FP$
tab1$availablequantity <- round(tab1$availablequantity,3)
tab1$quantity2cover <- round(tab1$quantity2cover,3)
sel_country <- country_input[country_input$label == input$btn_country, code]
if(nrow(tab1) > 0){
DT::datatable(tab1[geographicaream49_fi == sel_country], extensions = 'Buttons', filter = 'top',
rownames = FALSE, options = list(pageLength = 25,
dom = 'Bfrtip',
buttons = c('csv', 'excel', 'pdf')))
} else {
DT::datatable(data.table(), extensions = 'Buttons', filter = 'top',
rownames = FALSE, options = list(pageLength = 25,
dom = 'Bfrtip',
buttons = c('csv', 'excel', 'pdf')))
}
})
output$FPsecPar <- DT::renderDataTable( server = FALSE, {
req(input$btn_group_fbs_tab7, input$btn_ics_prod_tab7, input$btn_sua_elem_tab7,
input$btn_country, input$btn_year, input$btn_start_year)
sel_country <- country_input[country_input$label == input$btn_country, code]
tab2 <- FPfile$secondary # feedback$FP$secondary$tab
tab3 <- FPfile$tertiary # feedback$FP$tertiary$tab
tab4 <- FPfile$quaternary # feedback$FP$quaternary$tab
# if(!is.null(tab4) & !is.null(tab3) & !is.null(tab2)){
tab <- rbind(tab2, tab3, tab4)
tab$quantity2cover <- round(tab$quantity2cover, 3)
# tab <- rbind(tab, tab4)
if(nrow(tab) > 0){
DT::datatable(tab[geographicaream49_fi == sel_country], extensions = 'Buttons', filter = 'top',
rownames = FALSE, options = list(pageLength = 25,
dom = 'Bfrtip',
buttons = c('csv', 'excel', 'pdf')))
} else {
DT::datatable(data.table(), extensions = 'Buttons', filter = 'top',
rownames = FALSE, options = list(pageLength = 25,
dom = 'Bfrtip',
buttons = c('csv', 'excel', 'pdf')))
}
})
output$FPtabUncov <- DT::renderDataTable( server = FALSE, {
req(input$btn_group_fbs_tab7, input$btn_ics_prod_tab7, input$btn_sua_elem_tab7,
input$btn_country, input$btn_year, input$btn_start_year)
sel_country <- country_input[country_input$label == input$btn_country, code]
tabUncov <- FPfile$NotCovered
if(nrow(tabUncov) > 0){
DT::datatable(tabUncov[geographicaream49_fi == sel_country], extensions = 'Buttons', filter = 'top',
rownames = FALSE, options = list(pageLength = 25,
dom = 'Bfrtip',
buttons = c('csv', 'excel', 'pdf')))
} else {
DT::datatable(data.table(), extensions = 'Buttons', filter = 'top',
rownames = FALSE, options = list(pageLength = 25,
dom = 'Bfrtip',
buttons = c('csv', 'excel', 'pdf')))
}
})
The functions containing the re-processing calculations start now. They are activated by the ‘Save & recalc’ button in the tab.
The first thing the shiny checks is if the user has chosen to prioritize the input or the extraction rate during the calculations. If nothing has been chosen the a message appears and stops calculations.
# -- Save & recalculate ----
observeEvent(input$save, { # Opening Observe event
sel_country <- country_input[country_input$label == input$btn_country, code]
sel_years <- as.character(as.numeric(input$btn_start_year):as.numeric(input$btn_year))
sel_group_fbs <- as.character(groups_input[label %in% input$btn_group_fbs_tab7]$code)
sel_ics <- input$btn_ics_prod_tab7
if(input$radioErVSinput == 3){ # Choose Input or Er
showModal(modalDialog(
title = "Please select 'Extr rate' or 'Input' from the tab." ,
sprintf("This will confirm if you wish the Input or the Extraction rate figures to prevail.")
))
} else {
If calculations can start, the population data are loaded, if not already done.
# Load population data (almost always useful)
if(nrow(live_data$Pop) == 0)
{
elemKeys <- "511"
keyPop <- DatasetKey(domain = "population", dataset = "population_unpd", dimensions = list(
geographicAreaM49 = Dimension(name = "geographicAreaM49", keys = sel_country),
measuredElement = Dimension(name = "measuredElement", keys = elemKeys),
timePointYears = Dimension(name = "timePointYears", keys = sel_years)
))
popSWS <- GetData(keyPop)
setnames(popSWS,c("geographicAreaM49", "measuredElement"),c("geographicAreaM49_fi", "measuredElementSuaFbs"))
live_data$Pop <- popSWS
} else if(nrow(live_data$Pop) > 0 &
unique(live_data$Pop$geographicAreaM49_fi) != sel_country |
min(unique(live_data$Pop$timePointYears)) != input$btn_start_year |
max(unique(live_data$Pop$timePointYears)) != input$btn_year)
{
elemKeys <- "511"
keyPop <- DatasetKey(domain = "population", dataset = "population_unpd", dimensions = list(
geographicAreaM49 = Dimension(name = "geographicAreaM49", keys = sel_country),
measuredElement = Dimension(name = "measuredElement", keys = elemKeys),
timePointYears = Dimension(name = "timePointYears", keys = sel_years)
))
popSWS <- GetData(keyPop)
setnames(popSWS,c("geographicAreaM49", "measuredElement"),c("geographicAreaM49_fi", "measuredElementSuaFbs"))
live_data$Pop <- popSWS
} else
{
popSWS <- live_data$Pop
}
The user also have to choose what kind of recalculation to perform. By default the ‘No recalculation’ is selected and if the user starts recalculations without choosing any type of re-calculation a message appears reminding it. The option of ‘Complete’ recalculation must be chosen only in case of modification in the Global production or Commodity datasets.
# -- No recalculation ----
if(input$reprocess == 'No')
{# Opening input$reprocess == 'No'
# Only showing message to say to choose another option
showModal(modalDialog(
title = "Please select the type of recalculation." ,
sprintf("Select: 'Complete' if there are changes in the GP or CDB mappings;
'Only SUAbalanced' if you want to see changes at SUA level (only in this tab);
'Since SUAbalanced' if there is no change at GP and CDB level but you want to see effects at FBS level;
'Only Nutrients & FBS' if you want to take the SUA as it appears in this tab with no change and recalculate nutrients and standardization.")
))
If the option ‘Complete’ is chosen then the whole process done in the plugin is reproduced in this part with the help of 6 recalculation functions: ‘GPrecalc’, ‘CDBrecalc’, ‘SUAunbalCalc’, ‘SUAbalCalc’, ‘SUAnutrCalc’, ‘FBScalc’ described further on in the documentation. The first step is to load and process the Global production and the Commodity datasets with the updated information from the corresponding tabs.
# -- Complete recalculation ----
} else if (input$reprocess == 'Complete')
{ # Closing input$reprocess == 'No' & Opening input$reprocess == 'Complete'
newMapGP <- updated_mappings$GP
newMapCDB <- updated_mappings$CDB
showModal(modalDialog(
title = "Recalculating!" ,
sprintf("Please wait for the calculations to be completed.")
))
withProgress(message = 'Calculation in progress',
value = 0, {
Sys.sleep(0.1)
incProgress(0.15)
map_isscfc <- ReadDatatable('map_isscfc')
setnames(map_isscfc, "measured_item_isscfc", "measuredItemISSCFC")
map_asfis <- ReadDatatable('map_asfis')
setnames(map_asfis, c("asfis"), c("fisheriesAsfis"))
#++ Needed datasets ----
sel_country <- country_input[country_input$label == input$btn_country, code]
sel_years <- as.character(as.numeric(input$btn_start_year):as.numeric(input$btn_year))
## Get global production (from Production environment)
#++ Get whole Global production needed ----
if(nrow(InitialDatasets$GP) == 0)
{
KeyGlobal <- DatasetKey(domain = domainGP, dataset = datasetGP, dimensions = list(
geographicAreaM49_fi = Dimension(name = "geographicAreaM49_fi", keys = sel_country),
fisheriesAsfis = Dimension(name = "fisheriesAsfis", keys = GetCodeList("Fisheries", "fi_global_production","fisheriesAsfis" )[,code]),
fisheriesCatchArea = Dimension(name = "fisheriesCatchArea", keys = GetCodeList("Fisheries", "fi_global_production","fisheriesCatchArea" )[,code]),
measuredElement = Dimension(name = "measuredElement", keys = c("FI_001")),
timePointYears = Dimension(name = "timePointYears", keys = sel_years)))
globalProduction <- GetData(KeyGlobal)
} else if(nrow(InitialDatasets$GP) > 0 &
unique(InitialDatasets$GP$geographicAreaM49_fi) != sel_country |
min(unique(InitialDatasets$GP$timePointYears)) != input$btn_start_year |
max(unique(InitialDatasets$GP$timePointYears)) != input$btn_year)
{
KeyGlobal <- DatasetKey(domain = domainGP, dataset = datasetGP, dimensions = list(
geographicAreaM49_fi = Dimension(name = "geographicAreaM49_fi", keys = sel_country),
fisheriesAsfis = Dimension(name = "fisheriesAsfis", keys = GetCodeList("Fisheries", "fi_global_production","fisheriesAsfis" )[,code]),
fisheriesCatchArea = Dimension(name = "fisheriesCatchArea", keys = GetCodeList("Fisheries", "fi_global_production","fisheriesCatchArea" )[,code]),
measuredElement = Dimension(name = "measuredElement", keys = c("FI_001")),
timePointYears = Dimension(name = "timePointYears", keys = sel_years)))
globalProduction <- GetData(KeyGlobal)
} else
{
globalProduction <- InitialDatasets$GP
}
# Aggregate by fisheriesCatchArea
# Convert flags into ordinal factor so that simple aggregation is possible
# The function aggregateObservationFlag is too slow so flag are transformed into factors
globalProduction[geographicAreaM49_fi %in% c('830','833'), geographicAreaM49_fi := '826']
globalProduction$flagObservationStatus <- factor(globalProduction$flagObservationStatus,
levels = c('M', 'O', 'N', '', 'X', 'T', 'E', 'I'),
ordered = TRUE)
globalProduction <- globalProduction[ , list(ValueAggr = sum(Value, na.rm = TRUE),
flagObservationStatusAggr = max(flagObservationStatus),
flagMethodAggr = "s"),
by=c("geographicAreaM49_fi",
"fisheriesAsfis",
"measuredElement",
"timePointYears")]
setnames(globalProduction, names(globalProduction), c("geographicAreaM49_fi", "fisheriesAsfis",
"measuredElement", "timePointYears",
"Value", "flagObservationStatus",
"flagMethod"))
# Hard code change from FI_001 to 5510, both are Production in tonnes.
globalProduction$measuredElement <- ifelse(globalProduction$measuredElement == "FI_001", "5510", globalProduction$measuredElement)
#++ Start processing global production ----
newGP <- GPrecalc(GP = globalProduction, map_asfis = map_asfis, new_map_asfis = newMapGP, year = input$btn_year)
Sys.sleep(0.1)
incProgress(0.3)
#++ Get Commodities data ----
if(nrow(InitialDatasets$CDB) == 0)
{
KeyComm <- DatasetKey(domain = domainComm,
dataset = datasetCDB,
dimensions = list(geographicAreaM49_fi = Dimension(name = 'geographicAreaM49_fi',
keys = sel_country),
measuredElement = Dimension(name = 'measuredElement',
GetCodeList(domainComm,
datasetCDB,
'measuredElement')[,code]),
measuredItemISSCFC = Dimension(name = 'measuredItemISSCFC',
GetCodeList(domainComm,
datasetCDB,
'measuredItemISSCFC')[,code]),
timePointYears = Dimension(name = 'timePointYears', keys = sel_years )))
withProgress(message = 'Data loading in progress',
value = 0, {
Sys.sleep(0.25)
incProgress(0.25)
commodityDB <- GetData(KeyComm)
Sys.sleep(0.75)
incProgress(0.95)
})
commodityDB[geographicAreaM49_fi %in% c('830','833'), geographicAreaM49_fi := '826']
commodityDB$flagObservationStatus <- factor(commodityDB$flagObservationStatus,
levels = c('M', 'O', 'N', '', 'X', 'T', 'E', 'I'),
ordered = TRUE)
# Re-export in Export (quantity and values)
commodityDB[measuredElement == '5912', measuredElement := '5910'] # quantity
commodityDB[measuredElement == '5923', measuredElement := '5922'] # Value in 1000$
commodityDB[measuredElement == '5931', measuredElement := '5930'] # Unit value $/t
commodityDB <- commodityDB[!measuredElement %in% c('5907', '5937',
'5607', '5637',
'5906', '5940')]
# Isolate prices (not entering all the processing)
commodityDBValue <- copy(commodityDB)
commodityDBValue <- commodityDBValue[measuredElement %in% ValueElements]
# commodityDB <- commodityDB[!measuredElement %in% ValueElements]
InitialDatasets$CDB <- commodityDB
InitialDatasets$CDBVal <- commodityDBValue
} else if(nrow(InitialDatasets$CDB) > 0 &
unique(InitialDatasets$CDB$geographicAreaM49_fi) != sel_country |
min(unique(InitialDatasets$CDB$timePointYears)) != input$btn_start_year |
max(unique(InitialDatasets$CDB$timePointYears)) != input$btn_year)
{
KeyComm <- DatasetKey(domain = domainComm,
dataset = datasetCDB,
dimensions = list(geographicAreaM49_fi = Dimension(name = 'geographicAreaM49_fi',
keys = sel_country),
measuredElement = Dimension(name = 'measuredElement',
GetCodeList(domainComm,
datasetCDB,
'measuredElement')[,code]),
measuredItemISSCFC = Dimension(name = 'measuredItemISSCFC',
GetCodeList(domainComm,
datasetCDB,
'measuredItemISSCFC')[,code]),
timePointYears = Dimension(name = 'timePointYears', keys = sel_years )))
withProgress(message = 'Data loading in progress',
value = 0, {
Sys.sleep(0.25)
incProgress(0.25)
commodityDB <- GetData(KeyComm)
Sys.sleep(0.75)
incProgress(0.95)
})
commodityDB[geographicAreaM49_fi %in% c('830','833'), geographicAreaM49_fi := '826']
commodityDB$flagObservationStatus <- factor(commodityDB$flagObservationStatus,
levels = c('M', 'O', 'N', '', 'X', 'T', 'E', 'I'),
ordered = TRUE)
# Re-export in Export (quantity and values)
commodityDB[measuredElement == '5912', measuredElement := '5910'] # quantity
commodityDB[measuredElement == '5923', measuredElement := '5922'] # Value in 1000$
commodityDB[measuredElement == '5931', measuredElement := '5930'] # Unit value $/t
commodityDB <- commodityDB[!measuredElement %in% c('5907', '5937',
'5607', '5637',
'5906', '5940')]
# Isolate prices (not entering all the processing)
commodityDBValue <- copy(commodityDB)
commodityDBValue <- commodityDBValue[measuredElement %in% ValueElements]
# commodityDB <- commodityDB[!measuredElement %in% ValueElements]
InitialDatasets$CDB <- commodityDB
InitialDatasets$CDBVal <- commodityDBValue
} else
{
commodityDB <- InitialDatasets$CDB
}
#++ Start processing commodity DB ----
newCDB <- CDBrecalc(CDB = commodityDB,
map_isscfc = map_isscfc,
new_map_isscfc = newMapCDB,
year = input$btn_year)
Sys.sleep(0.1)
incProgress(0.45)
After the two initial datasets have been processed the SUA unbalanced is compiled with the ‘SUAunbalCalc’ function and stored in the ‘SUAunbal’ object. The just modified SUA is the saved into the ‘modifiedSUA’ object, this can come either directly from the shiny app tab or from an uploaded file, depending on the button selected by the user. Once the ‘modifiedSUA’ object is ready it is compared with the latest SUA save, the ‘SUAinit’ object. Now previous and current modifications have been merged together they are compared with the just calculated SUA unbalanced by merging the two SUA. Now the value of the newly updated SUA prevail on the SUA unbalanced except for the primary elements (production, import and export) that might have changed due to mapping changes.
#++ SUA unbalanced ----
SUAunbalResults <- SUAunbalCalc(globalProductionAggr = newGP, commodityDBAggr = newCDB)
SUAunbal <- SUAunbalResults$SUAunbal
initialUnbal <- SUAunbalResults$initialUnbal
if(input$csv_online == 1)
{
modifiedSUA0 <- rhandsontable::hot_to_r(input$sua_tab7)
modifiedSUA0 <- modifiedSUA0[ , -grep("F_", colnames(modifiedSUA0)), with = FALSE ]
modifiedSUA <- melt(modifiedSUA0,
id.vars = c(1,3:4),
measure.vars = 5:ncol(modifiedSUA0),
variable.name = 'timePointYears',
value.name = 'Value',
na.rm = TRUE)
setnames(modifiedSUA, c('Country', 'ICSprod', 'Element'),
c('geographicAreaM49_fi', 'measuredItemFaostat_L2', 'measuredElementSuaFbs'))
# modifiedSUA <- modifiedSUA[!measuredElementSuaFbs %in% ValueElements]
} else if(input$csv_online == 2)
{
#++ Pulling uploaded file ----
modifiedSUA0 <- recalc_value$SUAupload
setnames(modifiedSUA0, names(modifiedSUA0)[c(1,3,4)], c('geographicAreaM49_fi',
'measuredItemFaostat_L2',
'measuredElementSuaFbs'))
# Drop flag columns
colchosen <- names(modifiedSUA0)[!grepl('F_', names(modifiedSUA0))]
setDT(modifiedSUA0)
modifiedSUA0 <- modifiedSUA0[ , colchosen, with = FALSE]
yearNames <- sub("X", '', names(modifiedSUA0)[c(5:ncol(modifiedSUA0))])
setnames(modifiedSUA0, names(modifiedSUA0)[c(5:ncol(modifiedSUA0))], yearNames)
modifiedSUA0 <- as.data.table(modifiedSUA0)
modifiedSUA <- melt(modifiedSUA0,
id.vars = c(1,3:4),
measure.vars = 5:ncol(modifiedSUA0),
variable.name = 'timePointYears',
value.name = 'Value',
na.rm = TRUE)
modifiedSUA <- as.data.table(modifiedSUA)
modifiedSUA$Value <- as.numeric(modifiedSUA$Value)
}
modifiedSUA <- modifiedSUA[!measuredElementSuaFbs %in% elkeyNot2consider,]
# modifiedSUA <- modifiedSUA[!measuredElementSuaFbs %in% ValueElements,]
modifiedSUA <- modifiedSUA[!measuredElementSuaFbs %in% '5023',]
# First compare what changed with respect to the original table
if(nrow(recalc_value$SUAmodtab) == 0){
SUAinit <- recalc_value$SUAinit[!measuredElementSuaFbs %in% elkeyNot2consider,]
SUAinit <- SUAinit[measuredElementSuaFbs != '5023']
} else {
SUAinit <- recalc_value$SUAmodtab[!measuredElementSuaFbs %in% elkeyNot2consider,]
SUAinit <- SUAinit[measuredElementSuaFbs != '5023']
}
SUAcomp <- merge(SUAinit, modifiedSUA,
by = c('geographicAreaM49_fi', 'measuredItemFaostat_L2',
'measuredElementSuaFbs', 'timePointYears'),
suffixes = c('', 'Mod'),
all = TRUE)
setDT(SUAcomp)
SUAcomp <- SUAcomp[][!is.na(ValueMod) & Value != ValueMod | is.na(Value) , c('Value',
'flagObservationStatus',
'flagMethod') := list(ValueMod,
'E',
'f')]
SUAcomp <- SUAcomp[ , c('ValueMod') := NULL]
SUA2replace <- SUAcomp
# SUAbal$Value <- round(SUAbal$Value, 2)
# modifiedSUA$Value <- round(modifiedSUA$Value, 2)
SUAunbalMod <- merge(SUAunbal, SUA2replace,
by = c('geographicAreaM49_fi', 'measuredItemFaostat_L2',
'measuredElementSuaFbs', 'timePointYears'),
all = TRUE, suffixes = c('','Mod'))
SUAprimMod <- SUAunbalMod[ measuredElementSuaFbs %in% primaryEl]
SUAsecMod <- SUAunbalMod[!measuredElementSuaFbs %in% primaryEl]
SUAsecMod <- SUAsecMod[Value != ValueMod | is.na(Value),
c('Value', 'flagObservationStatus', 'flagMethod') := list(ValueMod, flagObservationStatusMod,
flagMethodMod)]
SUAunbalMod <- rbind(SUAprimMod, SUAsecMod)
# SUAunbalMod[round(Value, 2) != round(ValueMod, 2),
# c('Value', 'flagObservationStatus', 'flagMethod') := list(ValueMod, flagObservationStatusMod,
# flagMethodMod)]
SUAunbalMod[ , c('ValueMod', 'flagObservationStatusMod', 'flagMethodMod') := NULL]
Sys.sleep(0.1)
incProgress(0.5)
The new extraction rates are stored in a new object and the SUA balanced calculation are performed with the ‘SUAbalCalc’ function. Then the SUA with nutrients and the two FBS versions are also compiled with their corresponding functions. The new objects are then stored in the recalc_value and the updated_data objects.
#++ SUA balanced ----
eR <- SUAunbalMod[measuredElementSuaFbs == '5423']
# validate(
# need(length(input$radioErVSinput == 1),
# 'Choose only to update Extraction rates or Input'
# )
# )
primary <- unique(map_asfis$ics)
SUAunbalMod <- SUAunbalMod[measuredElementSuaFbs != '5166']
SUAbalResults <- SUAbalCalc(SUA = SUAunbalMod, eR = eR, use = input$radioErVSinput)
SUAbal <- SUAbalResults$SUA
SUAbal[measuredElementSuaFbs %in% c('5630', '5930'),flagMethod := 'c']
FPfile <<- SUAbalResults$FPproblems
newMessages <- SUAbalResults$msg
FPproblems <- SUAbalResults$FPproblems$NotCovered
SecNegAv <- SUAbalResults$NegAv
updated_table$NegAv <- SecNegAv
updated_table$FPproblems <- FPproblems
# Compare with modifiable table
Sys.sleep(0.1)
incProgress(0.65)
SUAwithNutrList <- SUAnutrCalc(SUAbalAvail = SUAbal, popSWS = popSWS)
recalc_value$SUAmodtab <- SUAwithNutrList$SUA2save
SUAwithNutr <- SUAwithNutrList$SUA2save
foodPercapita <- SUAwithNutrList$foodPercapita
Sys.sleep(0.1)
incProgress(0.80)
#++ FBS ----
FBS <- FBScalc(SUA2save = rbind(SUAwithNutr, foodPercapita), popSWS = popSWS)
faostatFBS <- FBS$faostat
fiasFBS <- FBS$fias
Sys.sleep(0.1)
incProgress(0.95)
})
#++ New SUA ----
updated_data$SUAunbal <- SUAunbal
updated_data$SUAbal <- SUAwithNutr
updated_data$FBSfaostat <- faostatFBS
updated_data$FBSfias <- fiasFBS
showModal(modalDialog(
title = "Recalculation completed!" ,
sprintf("Please check the new results.", newMessages$msg1, newMessages$msg2, newMessages$msg3)
))
workaround$V <- 1
If only the SUA recalculation is wanted what the code does is to take the SUA unbalanced, either from SWS or from the ‘live_data’ object compare it with the ‘SUA2replace’ object (merge between ‘modifiedSUA’ and ‘SUAinit’ as in the ‘Complete’ recalculation case) and update it with the newest values. The SUA balanced and SUA with nutrients are the calculated and stored as new SUA. Only the new SUA balanced will be stored.
# -- Only SUA balanced recalculation ----
} else if(input$reprocess == 'SUAb')
{ ## Closing input$reprocess == 'Complete' & Opening input$reprocess == 'SUAb'
showModal(modalDialog(
title = "Recalculating!" ,
sprintf("Please wait for the calculations to be completed.")
))
withProgress(message = 'Calculation in progress',
value = 0, {
Sys.sleep(0.1)
incProgress(0.25)
SUAunbal <- reloadDataToken(data = live_data$SUAu,
keycountry = sel_country,
minyear = input$btn_start_year,
maxyear = input$btn_year,
keydomain = domainComm,
keydataset = datasetSUAUlive,
keytoken = tokenSuaU)
if(!is.null(SUAunbal)){
ValueElements <- c('5922', '5930', '5622', '5630')
# SUAunbal <- SUAunbal[!measuredElementSuaFbs %in% ValueElements]
live_data$SUAu <- SUAunbal
} else {
SUAunbal <- live_data$SUAu
}
# SUAunbal <- SUAunbalResults$SUAunbal
# initialUnbal <- SUAunbalResults$initialUnbal
if(input$csv_online == 1)
{
modifiedSUA0 <- rhandsontable::hot_to_r(input$sua_tab7)
modifiedSUA0 <- modifiedSUA0[ , -grep("F_", colnames(modifiedSUA0)), with = FALSE ]
modifiedSUA <- melt(modifiedSUA0,
id.vars = c(1,3:4),
measure.vars = 5:ncol(modifiedSUA0),
variable.name = 'timePointYears',
value.name = 'Value',
na.rm = TRUE)
setnames(modifiedSUA, c('Country', 'ICSprod', 'Element'),
c('geographicAreaM49_fi', 'measuredItemFaostat_L2', 'measuredElementSuaFbs'))
# modifiedSUA <- modifiedSUA[!measuredElementSuaFbs %in% ValueElements]
} else if(input$csv_online == 2)
{
#++ Pulling uploaded file ----
modifiedSUA0 <- recalc_value$SUAupload
setnames(modifiedSUA0, names(modifiedSUA0)[c(1,3,4)], c('geographicAreaM49_fi',
'measuredItemFaostat_L2',
'measuredElementSuaFbs'))
# Drop flag columns
colchosen <- names(modifiedSUA0)[!grepl('F_', names(modifiedSUA0))]
setDT(modifiedSUA0)
modifiedSUA0 <- modifiedSUA0[ , colchosen, with = FALSE]
yearNames <- sub("X", '', names(modifiedSUA0)[c(5:ncol(modifiedSUA0))])
setnames(modifiedSUA0, names(modifiedSUA0)[c(5:ncol(modifiedSUA0))], yearNames)
modifiedSUA0 <- as.data.table(modifiedSUA0)
modifiedSUA <- melt(modifiedSUA0,
id.vars = c(1,3:4),
measure.vars = 5:ncol(modifiedSUA0),
variable.name = 'timePointYears',
value.name = 'Value',
na.rm = TRUE)
modifiedSUA <- as.data.table(modifiedSUA)
modifiedSUA$Value <- as.numeric(modifiedSUA$Value)
}
modifiedSUA <- modifiedSUA[!measuredElementSuaFbs %in% elkeyNot2consider,]
# modifiedSUA <- modifiedSUA[!measuredElementSuaFbs %in% ValueElements,]
modifiedSUA <- modifiedSUA[!measuredElementSuaFbs %in% '5023',]
# First compare what changed with respect to the original table
# if(nrow(recalc_value$SUAmodtab) > 0){
# browser()
# }
if(nrow(recalc_value$SUAmodtab) == 0){
SUAinit <- recalc_value$SUAinit[!measuredElementSuaFbs %in% elkeyNot2consider,]
SUAinit <- SUAinit[measuredElementSuaFbs != '5023']
} else {
SUAinit <- recalc_value$SUAmodtab[!measuredElementSuaFbs %in% elkeyNot2consider,]
SUAinit <- SUAinit[measuredElementSuaFbs != '5023']
}
SUAcomp <- merge(SUAinit, modifiedSUA,
by = c('geographicAreaM49_fi', 'measuredItemFaostat_L2',
'measuredElementSuaFbs', 'timePointYears'),
suffixes = c('', 'Mod'),
all = TRUE)
setDT(SUAcomp)
SUAcomp <- SUAcomp[][!is.na(ValueMod) &
Value != ValueMod | is.na(Value) ,
c('Value',
'flagObservationStatus',
'flagMethod') := list(ValueMod,
'E',
'f')]
SUAcomp <- SUAcomp[ , c('ValueMod') := NULL]
SUA2replace <- SUAcomp
# SUAbal$Value <- round(SUAbal$Value, 2)
# modifiedSUA$Value <- round(modifiedSUA$Value, 2)
SUAunbalMod <- merge(SUAunbal, SUA2replace,
by = c('geographicAreaM49_fi', 'measuredItemFaostat_L2',
'measuredElementSuaFbs', 'timePointYears'),
all = TRUE, suffixes = c('','Mod'))
SUAunbalMod <- SUAunbalMod[][Value != ValueMod | is.na(Value),
c('Value', 'flagObservationStatus', 'flagMethod') := list(ValueMod, flagObservationStatusMod,
flagMethodMod)]
# SUAunbalMod[round(Value, 2) != round(ValueMod, 2),
# c('Value', 'flagObservationStatus', 'flagMethod') := list(ValueMod, flagObservationStatusMod,
# flagMethodMod)]
SUAunbalMod[ , c('ValueMod', 'flagObservationStatusMod', 'flagMethodMod') := NULL]
Sys.sleep(0.1)
incProgress(0.5)
#++ SUA balanced ----
eR <- SUAunbalMod[measuredElementSuaFbs == '5423']
# validate(
# need(length(input$radioErVSinput == 1),
# 'Choose only to update Extraction rates or Input'
# )
# )
primary <- unique(map_asfis$ics)
SUAunbalMod <- SUAunbalMod[measuredElementSuaFbs != '5166']
if(any(names(SUAunbalMod) == 'sign')){
SUAunbalMod <- SUAunbalMod[sign := NULL]
}
SUAbalResults <- SUAbalCalc(SUA = SUAunbalMod,
eR = eR, use = input$radioErVSinput)
FPfile <<- SUAbalResults$FPproblems
SUAbal <- SUAbalResults$SUA
SUAbal[measuredElementSuaFbs %in% c('5630', '5930'),flagMethod := 'c']
newMessages <- SUAbalResults$msg
FPproblems <- SUAbalResults$FPproblems$NotCovered
SecNegAv <- SUAbalResults$NegAv
updated_table$NegAv <- SecNegAv
updated_table$FPproblems <- FPproblems
# Compare with modifiable table
Sys.sleep(0.1)
incProgress(0.65)
SUAwithNutrList <- SUAnutrCalc(SUAbalAvail = SUAbal, popSWS = popSWS)
recalc_value$SUAmodtab <- SUAwithNutrList$SUA2save
SUAwithNutr <- SUAwithNutrList$SUA2save
foodPercapita <- SUAwithNutrList$foodPercapita
# Sys.sleep(0.80)
# incProgress(0.80)
#
#-- FBS ---
# FBS <- FBScalc(SUA2save = SUAwithNutr, popSWS = popSWS)
#
# faostatFBS <- FBS$faostat
# fiasFBS <- FBS$fias
Sys.sleep(0.1)
incProgress(0.95)
})
#++ New SUA ----
# updated_data$SUAunbal <- SUAunbal
updated_data$SUAbal <- SUAwithNutr
# updated_data$FBSfaostat <- faostatFBS
# updated_data$FBSfias <- fiasFBS
showModal(modalDialog(
title = "Recalculation completed!" ,
sprintf("Please check the new results.", newMessages$msg1, newMessages$msg2, newMessages$msg3)
))
workaround$V <- 1
If both SUA balanced and FBS want to be recalculated the procedure is the same as with only the SUA balanced but with the ‘FBScalc’ function in addition and with all the new objects stored again.
# -- SUA balanced + FBS recalculation ----
} else if(input$reprocess == 'SUAbTot')
{ # Closing input$reprocess == 'SUAb' & Opening input$reprocess == 'SUAbTot'
showModal(modalDialog(
title = "Recalculating!" ,
sprintf("Please wait for the calculations to be completed.")
))
withProgress(message = 'Calculation in progress',
value = 0, {
Sys.sleep(0.1)
incProgress(0.25)
#put SUAunbal #SUAunbalCalc(globalProductionAggr = newGP, commodityDBAggr = newCDB)
SUAunbal <- reloadDataToken(data = live_data$SUAu,
keycountry = sel_country,
minyear = input$btn_start_year,
maxyear = input$btn_year,
keydomain = domainComm,
keydataset = datasetSUAUlive,
keytoken = tokenSuaU)
if(!is.null(SUAunbal)){
ValueElements <- c('5922', '5930', '5622', '5630')
# SUAunbal <- SUAunbal[!measuredElementSuaFbs %in% ValueElements]
live_data$SUAu <- SUAunbal
} else {
SUAunbal <- live_data$SUAu
}
if(input$csv_online == 1){
modifiedSUA0 <- rhandsontable::hot_to_r(input$sua_tab7)
modifiedSUA0 <- modifiedSUA0[ , -grep("F_", colnames(modifiedSUA0)), with = FALSE ]
modifiedSUA <- melt(modifiedSUA0,
id.vars = c(1,3:4),
measure.vars = 5:ncol(modifiedSUA0),
variable.name = 'timePointYears',
value.name = 'Value',
na.rm = TRUE)
setnames(modifiedSUA, c('Country', 'ICSprod', 'Element'),
c('geographicAreaM49_fi', 'measuredItemFaostat_L2', 'measuredElementSuaFbs'))
# modifiedSUA <- modifiedSUA[!measuredElementSuaFbs %in% ValueElements]
} else if(input$csv_online == 2){
#++ Pulling uploaded file ----
modifiedSUA0 <- recalc_value$SUAupload
setnames(modifiedSUA0, names(modifiedSUA0)[c(1,3,4)], c('geographicAreaM49_fi',
'measuredItemFaostat_L2',
'measuredElementSuaFbs'))
# Drop flag columns
colchosen <- names(modifiedSUA0)[!grepl('F_', names(modifiedSUA0))]
setDT(modifiedSUA0)
modifiedSUA0 <- modifiedSUA0[ , colchosen, with = FALSE]
yearNames <- sub("X", '', names(modifiedSUA0)[c(5:ncol(modifiedSUA0))])
setnames(modifiedSUA0, names(modifiedSUA0)[c(5:ncol(modifiedSUA0))], yearNames)
modifiedSUA0 <- as.data.table(modifiedSUA0)
modifiedSUA <- melt(modifiedSUA0,
id.vars = c(1,3:4),
measure.vars = 5:ncol(modifiedSUA0),
variable.name = 'timePointYears',
value.name = 'Value',
na.rm = TRUE)
modifiedSUA <- as.data.table(modifiedSUA)
modifiedSUA$Value <- as.numeric(modifiedSUA$Value)
}
modifiedSUA <- modifiedSUA[!measuredElementSuaFbs %in% elkeyNot2consider,]
# modifiedSUA <- modifiedSUA[!measuredElementSuaFbs %in% ValueElements,]
modifiedSUA <- modifiedSUA[!measuredElementSuaFbs %in% '5023',]
# First compare what changed with respect to the original table
if(nrow(recalc_value$SUAmodtab) == 0){
SUAinit <- recalc_value$SUAinit[!measuredElementSuaFbs %in% elkeyNot2consider,]
SUAinit <- SUAinit[measuredElementSuaFbs != '5023']
} else {
SUAinit <- recalc_value$SUAmodtab[!measuredElementSuaFbs %in% elkeyNot2consider,]
SUAinit <- SUAinit[measuredElementSuaFbs != '5023']
}
SUAcomp <- merge(SUAinit, modifiedSUA,
by = c('geographicAreaM49_fi', 'measuredItemFaostat_L2',
'measuredElementSuaFbs', 'timePointYears'),
suffixes = c('', 'Mod'),
all = TRUE)
setDT(SUAcomp)
SUAcomp <- SUAcomp[][!is.na(ValueMod) & Value != ValueMod | is.na(Value) , c('Value',
'flagObservationStatus',
'flagMethod') := list(ValueMod,
'E',
'f')]
SUAcomp <- SUAcomp[ , c('ValueMod') := NULL]
SUA2replace <- SUAcomp
# SUAbal$Value <- round(SUAbal$Value, 2)
# modifiedSUA$Value <- round(modifiedSUA$Value, 2)
SUAunbalMod <- merge(SUAunbal, SUA2replace,
by = c('geographicAreaM49_fi', 'measuredItemFaostat_L2',
'measuredElementSuaFbs', 'timePointYears'),
all = TRUE, suffixes = c('','Mod'))
SUAunbalMod <- SUAunbalMod[][Value != ValueMod | is.na(Value),
c('Value', 'flagObservationStatus', 'flagMethod') := list(ValueMod, flagObservationStatusMod,
flagMethodMod)]
# SUAunbalMod[round(Value, 2) != round(ValueMod, 2),
# c('Value', 'flagObservationStatus', 'flagMethod') := list(ValueMod, flagObservationStatusMod,
# flagMethodMod)]
SUAunbalMod[ , c('ValueMod', 'flagObservationStatusMod', 'flagMethodMod') := NULL]
Sys.sleep(0.1)
incProgress(0.5)
#++ SUA balanced ----
eR <- SUAunbalMod[measuredElementSuaFbs == '5423']
# validate(
# need(length(input$radioErVSinput == 1),
# 'Choose only to update Extraction rates or Input'
# )
# )
primary <- unique(map_asfis$ics)
SUAunbalMod <- SUAunbalMod[measuredElementSuaFbs != '5166']
SUAbalResults <- SUAbalCalc(SUA = SUAunbalMod, eR = eR, use = input$radioErVSinput)
SUAbal <- SUAbalResults$SUA
SUAbal[measuredElementSuaFbs %in% c('5630', '5930'),flagMethod := 'c']
FPfile <<- SUAbalResults$FPproblems
newMessages <- SUAbalResults$msg
FPproblems <- SUAbalResults$FPproblems$NotCovered
SecNegAv <- SUAbalResults$NegAv
updated_table$NegAv <- SecNegAv
updated_table$FPproblems <- FPproblems
# Compare with modifiable table
Sys.sleep(0.1)
incProgress(0.65)
SUAwithNutrList <- SUAnutrCalc(SUAbalAvail = SUAbal, popSWS = popSWS)
recalc_value$SUAmodtab <- SUAwithNutrList$SUA2save
SUAwithNutr <- SUAwithNutrList$SUA2save
foodPercapita <- SUAwithNutrList$foodPercapita
Sys.sleep(0.1)
incProgress(0.80)
#++ FBS ----
FBS <- FBScalc(SUA2save = rbind(SUAwithNutr, foodPercapita), popSWS = popSWS)
faostatFBS <- FBS$faostat
fiasFBS <- FBS$fias
Sys.sleep(0.1)
incProgress(0.95)
})
#++ New SUA ----
updated_data$SUAunbal <- SUAunbal
updated_data$SUAbal <- SUAwithNutr
updated_data$FBSfaostat <- faostatFBS
updated_data$FBSfias <- fiasFBS
showModal(modalDialog(
title = "Recalculation completed!" ,
sprintf("Please check the new results.", newMessages$msg1, newMessages$msg2, newMessages$msg3)
))
workaround$V <- 1
If only the FBS have to be recalculated as the SUA are those specified in the tab the SUA balanced is derived only updating the SUA balanced through the usual merging, the function ‘SUAbalCalc’ is not run and only the nutrients and the FBSs are recalculated and stored again.
# -- Only FBS recalculation ----
} else if(input$reprocess == 'NutFbs')
{ # Closing input$reprocess == 'SUAbTot' & Opening input$reprocess == 'NutFbs'
showModal(modalDialog(
title = "Recalculating!" ,
sprintf("Please wait for the calculations to be completed.")
))
withProgress(message = 'Calculation in progress',
value = 0, {
Sys.sleep(0.1)
incProgress(0.15)
SUAbal <- reloadDataToken(data = live_data$SUAb,
keycountry = sel_country,
minyear = input$btn_start_year,
maxyear = input$btn_year,
keydomain = domainComm,
keydataset = datasetSUABlive,
keytoken = tokenSuaB)
if(!is.null(SUAbal)){
ValueElements <- c('5922', '5930', '5622', '5630')
liveBval <- copy(SUAbal)
liveBval <- liveBval[measuredElementSuaFbs %in% ValueElements]
live_data$SUAbVal <- liveBval
# SUAbal <- SUAbal[!measuredElementSuaFbs %in% ValueElements]
live_data$SUAb <- SUAbal
} else {
SUAbal <- live_data$SUAb
}
# Once session Sua balanced loaded, SUA fron tab is pulled (no nutrients)
if(input$csv_online == 1){
modifiedSUA0 <- rhandsontable::hot_to_r(input$sua_tab7)
modifiedSUA0 <- modifiedSUA0[ , -grep("F_", colnames(modifiedSUA0)), with = FALSE ]
modifiedSUA <- melt(modifiedSUA0,
id.vars = c(1,3:4),
measure.vars = 5:ncol(modifiedSUA0),
variable.name = 'timePointYears',
value.name = 'Value',
na.rm = TRUE)
setnames(modifiedSUA, c('Country', 'ICSprod', 'Element'),
c('geographicAreaM49_fi', 'measuredItemFaostat_L2', 'measuredElementSuaFbs'))
# modifiedSUA <- modifiedSUA[!measuredElementSuaFbs %in% ValueElements]
} else if(input$csv_online == 2){
#++ Pulling uploaded file ----
modifiedSUA0 <- recalc_value$SUAupload
setnames(modifiedSUA0, names(modifiedSUA0)[c(1,3,4)], c('geographicAreaM49_fi',
'measuredItemFaostat_L2',
'measuredElementSuaFbs'))
# Drop flag columns
colchosen <- names(modifiedSUA0)[!grepl('F_', names(modifiedSUA0))]
setDT(modifiedSUA0)
modifiedSUA0 <- modifiedSUA0[ , colchosen, with = FALSE]
yearNames <- sub("X", '', names(modifiedSUA0)[c(5:ncol(modifiedSUA0))])
setnames(modifiedSUA0, names(modifiedSUA0)[c(5:ncol(modifiedSUA0))], yearNames)
modifiedSUA0 <- as.data.table(modifiedSUA0)
modifiedSUA <- melt(modifiedSUA0,
id.vars = c(1,3:4),
measure.vars = 5:ncol(modifiedSUA0),
variable.name = 'timePointYears',
value.name = 'Value',
na.rm = TRUE)
modifiedSUA <- as.data.table(modifiedSUA)
modifiedSUA$Value <- as.numeric(modifiedSUA$Value)
}
modifiedSUA <- modifiedSUA[!measuredElementSuaFbs %in% elkeyNot2consider,]
# modifiedSUA <- modifiedSUA[!measuredElementSuaFbs %in% ValueElements,]
# modifiedSUA <- modifiedSUA[!measuredElementSuaFbs %in% '5023',]
# First compare what changed with respect to the original table
if(nrow(recalc_value$SUAmodtab) == 0){
SUAinit <- recalc_value$SUAinit[!measuredElementSuaFbs %in% elkeyNot2consider,]
# SUAinit <- SUAinit[measuredElementSuaFbs != '5023']
} else {
SUAinit <- recalc_value$SUAmodtab[!measuredElementSuaFbs %in% elkeyNot2consider,]
# SUAinit <- SUAinit[measuredElementSuaFbs != '5023']
}
SUAcomp <- merge(SUAinit, modifiedSUA,
by = c('geographicAreaM49_fi', 'measuredItemFaostat_L2',
'measuredElementSuaFbs', 'timePointYears'),
suffixes = c('', 'Mod'),
all = TRUE)
setDT(SUAcomp)
SUAcomp <- SUAcomp[][!is.na(ValueMod) & Value != ValueMod | is.na(Value) , c('Value',
'flagObservationStatus',
'flagMethod') := list(ValueMod,
'E',
'f')]
SUAcomp <- SUAcomp[ , c('ValueMod') := NULL]
SUA2replace <- SUAcomp
# SUAbal$Value <- round(SUAbal$Value, 2)
# modifiedSUA$Value <- round(modifiedSUA$Value, 2)
SUAbalMod <- merge(SUAbal, SUA2replace,
by = c('geographicAreaM49_fi', 'measuredItemFaostat_L2',
'measuredElementSuaFbs', 'timePointYears'),
all = TRUE, suffixes = c('','Mod'))
SUAbalMod <- SUAbalMod[][Value != ValueMod | is.na(Value),
c('Value', 'flagObservationStatus', 'flagMethod') := list(ValueMod, flagObservationStatusMod,
flagMethodMod)]
# SUAunbalMod[round(Value, 2) != round(ValueMod, 2),
# c('Value', 'flagObservationStatus', 'flagMethod') := list(ValueMod, flagObservationStatusMod,
# flagMethodMod)]
SUAbalMod[ , c('ValueMod', 'flagObservationStatusMod', 'flagMethodMod') := NULL]
Sys.sleep(0.1)
incProgress(0.5)
SUAwithNutrList <- SUAnutrCalc(SUAbalAvail = SUAbalMod, popSWS = popSWS)
recalc_value$SUAmodtab <- SUAwithNutrList$SUA2save
SUAwithNutr <- SUAwithNutrList$SUA2save
foodPercapita <- SUAwithNutrList$foodPercapita
Sys.sleep(0.1)
incProgress(0.80)
#++ FBS ----
FBS <- FBScalc(SUA2save = rbind(SUAwithNutr, foodPercapita), popSWS = popSWS)
faostatFBS <- FBS$faostat
fiasFBS <- FBS$fias
Sys.sleep(0.1)
incProgress(0.95)
})
#++ New SUA ----
updated_data$SUAunbal <- ifelse(nrow(updated_data$SUAunbal) == 0,
live_data$SUAu, updated_data$SUAunbal)
updated_data$SUAbal <- SUAwithNutr
updated_data$FBSfaostat <- faostatFBS
updated_data$FBSfias <- fiasFBS
showModal(modalDialog(
title = "Recalculation completed!" ,
sprintf("Please check the new results.") #, newMessages$msg1, newMessages$msg2, newMessages$msg3)
))
workaround$V <- 1
} # Closing input$reprocess == 'NutFbs'
}
}) # Closing Observe event
4.3.12 ‘Data update’ tab
The tab has the same structure as the ‘Overview’ tab but it uses the FBS recalculated in the ‘Data validation’ tab and stored in the updated_data$FBSfias object.
# Eighth tab, showing changes consequences
consequenceTab_reac <- reactive({
req(input$btn_country, input$btn_year, input$btn_start_year, input$btn_element_fbs)
if(workaround$V != 1) return(NULL)
if(nrow(updated_data$FBSfias)== 0 ) return(NULL)
sel_country <- country_input[country_input$label == input$btn_country, code]
sel_years <- as.character(as.numeric(input$btn_start_year):as.numeric(input$btn_year))
sel_elements_fbs <- as.character(element_input[label == input$btn_element_fbs]$code)
sel_fbs_groups <- as.character(c(seq(10, 90, by = 10), 99))
fiasFBSupd <- updated_data$FBSfias
validate(
need(nrow(fiasFBSupd) != 0, 'No update to show')
)
fiasFBSupd <- fiasFBSupd[measuredElementSuaFbs == sel_elements_fbs]
FBSfrozen <- frozen_data$FBS
FBSfrozen <- FBSfrozen[measuredElementSuaFbs == sel_elements_fbs]
# Now only showing value present both in frozen and live, CHANGE?
frozenVSlive8 <- merge(FBSfrozen, fiasFBSupd,
by = c('geographicAreaM49_fi', 'measuredItemFaostat_L2',
'measuredElementSuaFbs', 'timePointYears'),
suffixes = c('Frozen', 'Updated'), all = TRUE)
frozenVSlive8[is.na(ValueFrozen), flagObservationStatusFrozen := 'O']
frozenVSlive8[is.na(ValueUpdated), flagObservationStatusUpdated := 'O']
frozenVSlive8[is.na(ValueFrozen), flagMethodFrozen := '-']
frozenVSlive8[is.na(ValueUpdated), flagMethodUpdated := '-']
frozenVSlive8[is.na(ValueFrozen), ValueFrozen := 0]
frozenVSlive8[is.na(ValueUpdated), ValueUpdated := 0]
frozen2plot <- frozenVSlive8[ , .(geographicAreaM49_fi,
measuredItemFaostat_L2,
measuredElementSuaFbs,
timePointYears,
ValueFrozen)]
frozen2plot[ , type := 'Frozen']
live2plot <- frozenVSlive8[ , .(geographicAreaM49_fi,
measuredItemFaostat_L2,
measuredElementSuaFbs,
timePointYears,
ValueUpdated)]
live2plot[ , type := 'Updated']
setnames(frozen2plot, 'ValueFrozen', 'Value')
setnames(live2plot, 'ValueUpdated', 'Value')
data4plot8 <- rbind(frozen2plot, live2plot)
return(list(tab = frozenVSlive8, plot = data4plot8))
})
output$fbs_fias_tab8 <- DT::renderDataTable( server = FALSE, {
req(input$btn_country, input$btn_year, input$btn_start_year, input$btn_element_fbs)
if(is.null(consequenceTab_reac()$tab)) return(NULL)
fbs_fias_tab_upd <- copy(consequenceTab_reac()$tab)
grandtotal <- copy(fbs_fias_tab_upd)
grandtotal$flagObservationStatusFrozen <- factor(grandtotal$flagObservationStatusFrozen,
levels = c('M', 'O', 'N', '', 'X', 'T', 'E', 'I'),
ordered = TRUE)
grandtotal$flagObservationStatusUpdated <- factor(grandtotal$flagObservationStatusUpdated,
levels = c('M', 'O', 'N', '', 'X', 'T', 'E', 'I'),
ordered = TRUE)
grandtotal <- grandtotal[ , c('ValueFrozen', 'ValueUpdated', 'measuredItemFaostat_L2',
'flagObservationStatusFrozen', 'flagMethodFrozen',
'flagObservationStatusUpdated', 'flagMethodUpdated') := list(sum(ValueFrozen, na.rm = TRUE),
sum(ValueUpdated, na.rm = TRUE),
'Total',
max(flagObservationStatusFrozen), 's',
max(flagObservationStatusUpdated), 's'),
by = c('geographicAreaM49_fi',
'measuredElementSuaFbs',
'timePointYears')]
setkey(grandtotal)
grandtotal <- grandtotal[!duplicated(grandtotal)]
fbs_fias_tot_upd <- rbind(fbs_fias_tab_upd, grandtotal)
setnames(fbs_fias_tot_upd, c('geographicAreaM49_fi', 'measuredItemFaostat_L2',
'measuredElementSuaFbs', 'timePointYears',
'flagObservationStatusFrozen', 'flagMethodFrozen',
'flagObservationStatusUpdated', 'flagMethodUpdated'),
c('Country', 'FBSgroup', 'Element', 'Year', 'FlagFrozen1', 'FlagFrozen2',
'FlagUpdated1', 'FlagUpdated2'))
fbs_fias_tot_upd[ , Diff := round(ValueFrozen - ValueUpdated, 3)]
DT::datatable(fbs_fias_tot_upd, extensions = 'Buttons', filter = 'top',
rownames = FALSE, options = list(dom = 'Bfrtip',
buttons = c('csv', 'excel', 'pdf'))) %>%
formatStyle(columns = c('Diff'), target = 'row',
color = styleInterval(c(-0.001, 0.001), c('red', ' ', 'red')))
})
output$gg_plot_tab8 <- renderPlot({
req(input$btn_country, input$btn_year, input$btn_start_year, input$btn_element_fbs)
if(is.null(consequenceTab_reac()$plot)) return(NULL)
fbs_fias_upd <- copy(consequenceTab_reac()$plot)
grandtotal <- copy(fbs_fias_upd)
grandtotal <- grandtotal[ , c('Value', 'measuredItemFaostat_L2') := list(sum(Value, na.rm = TRUE), 'Total'),
by = c('geographicAreaM49_fi',
'measuredElementSuaFbs',
'timePointYears', 'type')]
setkey(grandtotal)
grandtotal <- grandtotal[!duplicated(grandtotal)]
fbs_fias_tot_upd <- rbind(fbs_fias_upd, grandtotal)
ggplot(data = fbs_fias_tot_upd, aes(x = timePointYears, y = Value)) +
geom_line(aes(group = type, color = type), size = 0.7) +
facet_wrap( ~ measuredItemFaostat_L2, scales="free") +
labs(x = 'Year', color = '') +
theme(text = element_text(size= 15))
})
4.3.13 ‘Data saving’ tab
The first part of this tab replicates what was programmed for the token of the working dataset whereas here the user has to insert the token of the validated datasets. The update structure is exactly the same.
# -- Insert token validated ----
output$btn_token1val <- renderUI({
textInput(inputId = 'btn_token1val', label = "Insert the 'SUA unbalanced validated' session token", value = NA)
})
output$btn_token2val <- renderUI({
textInput(inputId = 'btn_token2val', label = "Insert the 'SUA balanced validated' session token", value = NA)
})
output$btn_token3val <- renderUI({
textInput(inputId = 'btn_token3val', label = "Insert the 'FBS FIAS validated' session token", value = NA)
})
output$btn_token4val <- renderUI({
textInput(inputId = 'btn_token4val', label = "Insert the 'FBS Faostat validated' session token", value = NA)
})
token_val_reac <- reactive({
tokenTabVal <- ReadDatatable('fi_sua_fbs_token_val')
return(tokenTabVal)
})
output$token_val_tab <- DT::renderDataTable( server = FALSE, {
tokenOutVal <- token_val_reac()
DT::datatable(tokenOutVal)
})
observeEvent(input$btn_upd_token_val, {
tokenTabVal <- ReadDatatable('fi_sua_fbs_token_val', readOnly = FALSE)
t1 <- ifelse(is.na(input$btn_token1val), tokenTabVal$token[1], input$btn_token1val)
t2 <- ifelse(is.na(input$btn_token2val), tokenTabVal$token[2], input$btn_token2val)
t3 <- ifelse(is.na(input$btn_token3val), tokenTabVal$token[3], input$btn_token3val)
t4 <- ifelse(is.na(input$btn_token4val), tokenTabVal$token[4], input$btn_token4val)
date <- as.character(Sys.Date())
tokenTabVal[ , token := c(t1, t2, t3, t4) ]
tokenTabVal[ , last_upd := date]
changeset <- Changeset('fi_sua_fbs_token_val')
AddModifications(changeset, tokenTabVal)
Finalise(changeset)
tokenSuaUval <<- t1
tokenSuaBval <<- t2
tokenFbsFiasval <<- t3
tokenFbsFaostatval <<- t4
showModal(modalDialog(
title = "Token updated." ,
sprintf("The chosen sessions will be updated.")
))
})
In order to update the datasets in the SWS the user has to choose if update the whole selected time series or only the last year selected. Then, once the user press the ‘Update SWS’ button, the year(s) to update are selected and the SUAs and FBSs filtered accordingly. Subsequently, a series of dataset update starts. First all the existing data and flags are saved as NAs, then they are substituted with the new values. If the user is satisfied the only missing operation is to save these data directly into the SWS.
observeEvent(input$update, {
sel_country <- country_input[country_input$label == input$btn_country, code]
# Cancel data from SUA and FBS
if(input$time2save == 3){
showModal(modalDialog(
title = "Missing info!" ,
sprintf("Please select years to update.")
))
} else{
if(input$time2save == 1){
sel_years <- input$btn_year
} else if(input$time2save == 2) {
sel_years <- as.character(as.numeric(input$btn_start_year):as.numeric(input$btn_year))
} else {
}
# Datasets
if(!is.data.table(updated_data$SUAunbal)){
SUAunbalTot <- reloadDataToken(data = live_data$SUAu,
keycountry = sel_country,
minyear = input$btn_start_year,
maxyear = input$btn_year,
keydomain = domainComm,
keydataset = datasetSUAUlive,
keytoken = tokenSuaU)
if(!is.null(SUAunbalTot)){
SUAun <- SUAunbalTot
} else {
SUAun <- live_data$SUAu
}
} else {
SUAun <- updated_data$SUAunbal
}
SUAun <- SUAun[timePointYears %in% sel_years]
SUAb <- updated_data$SUAbal
SUAb <- SUAb[timePointYears %in% sel_years]
# SUAbVal <- live_data$SUAbVal
# SUAbVal <- SUAbVal[timePointYears %in% sel_years]
#
# SUAb <- rbind(SUAb, SUAbVal)
FBSfias <- updated_data$FBSfias
FBSfias <- FBSfias[timePointYears %in% sel_years]
FBSfaostat <- updated_data$FBSfaostat
FBSfaostat <- FBSfaostat[timePointYears %in% sel_years]
message('Saving datasets...')
#-- Save SUA unbalanced validated -----
if(localrun){
if(CheckDebug()){
library(faoswsModules)
SETTINGS = ReadSettings("sws.yml")
R_SWS_SHARE_PATH = SETTINGS[["share"]]
SetClientFiles(SETTINGS[["certdir"]])
GetTestEnvironment(baseUrl = SETTINGS[["server"]],
token = tokenSuaUval)
}
} else {
R_SWS_SHARE_PATH = "Z:"
SetClientFiles("/srv/shiny-server/.R/QA/")
GetTestEnvironment(baseUrl = "https://swsqa.aws.fao.org:8181",
token = tokenSuaUval)
}
KeySUAun <- DatasetKey(domain = domainComm, dataset = datasetSUAUval, dimensions = list(
geographicAreaM49_fi = Dimension(name = "geographicAreaM49_fi", keys = sel_country),
measuredElementSuaFbs = Dimension(name = "measuredElementSuaFbs",
GetCodeList(domainComm, datasetFBSfrozen,"measuredElementSuaFbs" )[,code]),
measuredItemFaostat_L2 = Dimension(name = "measuredItemFaostat_L2",
GetCodeList(domainComm, datasetFBSfrozen,"measuredItemFaostat_L2" )[,code]),
timePointYears = Dimension(name = "timePointYears", keys = as.character(sel_years) )))
SUAun2blank <- GetData(KeySUAun)
SUAun2blank <- SUAun2blank[ , c('Value', 'flagObservationStatus', 'flagMethod') := list(NA, NA, NA)]
SaveData(domain = domainComm,
dataset = datasetSUAUval,
data = SUAun2blank,
waitTimeout = Inf)
SUAun$timePointYears <- as.character(SUAun$timePointYears)
SaveData(domain = domainComm,
dataset = datasetSUAUval,
data = SUAun,
waitTimeout = Inf)
message('SUA unbalanced validated saved')
showModal(modalDialog(
title = "Updating dataset..." ,
sprintf("1/8")
))
#-- Save SUA unbalanced ----
if(localrun){
if(CheckDebug()){
library(faoswsModules)
SETTINGS = ReadSettings("sws.yml")
R_SWS_SHARE_PATH = SETTINGS[["share"]]
SetClientFiles(SETTINGS[["certdir"]])
GetTestEnvironment(baseUrl = SETTINGS[["server"]],
token = tokenSuaU)
}
} else {
R_SWS_SHARE_PATH = "Z:"
SetClientFiles("/srv/shiny-server/.R/QA/")
GetTestEnvironment(baseUrl = "https://swsqa.aws.fao.org:8181",
token = tokenSuaU)
}
KeySUAunLive <- DatasetKey(domain = domainComm, dataset = datasetSUAUlive, dimensions = list(
geographicAreaM49_fi = Dimension(name = "geographicAreaM49_fi", keys = sel_country),
measuredElementSuaFbs = Dimension(name = "measuredElementSuaFbs",
GetCodeList(domainComm, datasetFBSfrozen,"measuredElementSuaFbs" )[,code]),
measuredItemFaostat_L2 = Dimension(name = "measuredItemFaostat_L2",
GetCodeList(domainComm, datasetFBSfrozen,"measuredItemFaostat_L2" )[,code]),
timePointYears = Dimension(name = "timePointYears", keys = as.character(sel_years) )))
SUAunlive2blank <- GetData(KeySUAunLive)
SUAunlive2blank <- SUAunlive2blank[ , c('Value', 'flagObservationStatus', 'flagMethod') := list(NA, NA, NA)]
SaveData(domain = domainComm,
dataset = datasetSUAUlive,
data = SUAunlive2blank,
waitTimeout = Inf)
SaveData(domain = domainComm,
dataset = datasetSUAUlive,
data = SUAun,
waitTimeout = Inf)
message('SUA unbalanced live saved')
showModal(modalDialog(
title = "Updating dataset..." ,
sprintf("2/8")
))
#-- Save SUA balanced validated ----
if(localrun){
if(CheckDebug()){
library(faoswsModules)
SETTINGS = ReadSettings("sws.yml")
R_SWS_SHARE_PATH = SETTINGS[["share"]]
SetClientFiles(SETTINGS[["certdir"]])
GetTestEnvironment(baseUrl = SETTINGS[["server"]],
token = tokenSuaBval)
}
} else {
R_SWS_SHARE_PATH = "Z:"
SetClientFiles("/srv/shiny-server/.R/QA/")
GetTestEnvironment(baseUrl = "https://swsqa.aws.fao.org:8181",
token = tokenSuaBval)
}
KeySUAb <- DatasetKey(domain = domainComm, dataset = datasetSUABval, dimensions = list(
geographicAreaM49_fi = Dimension(name = "geographicAreaM49_fi", keys = sel_country),
measuredElementSuaFbs = Dimension(name = "measuredElementSuaFbs",
GetCodeList(domainComm, datasetFBSfrozen,"measuredElementSuaFbs" )[,code]),
measuredItemFaostat_L2 = Dimension(name = "measuredItemFaostat_L2",
GetCodeList(domainComm, datasetFBSfrozen,"measuredItemFaostat_L2" )[,code]),
timePointYears = Dimension(name = "timePointYears", keys = as.character(sel_years) )))
SUAb2blank <- GetData(KeySUAb)
if(nrow(SUAb2blank) > 0){
SUAb2blank <- SUAb2blank[ , c('Value', 'flagObservationStatus', 'flagMethod') := list(NA, NA, NA)]
SaveData(domain = domainComm,
dataset = datasetSUABval,
data = SUAb2blank,
waitTimeout = Inf)
}
SUAb$timePointYears <- as.character(SUAb$timePointYears)
SaveData(domain = domainComm,
dataset = datasetSUABval,
data = SUAb,
waitTimeout = Inf)
message('SUA balanced validated saved')
showModal(modalDialog(
title = "Updating dataset..." ,
sprintf("3/8")
))
#-- Save SUA balanced ----
if(localrun){
if(CheckDebug()){
library(faoswsModules)
SETTINGS = ReadSettings("sws.yml")
R_SWS_SHARE_PATH = SETTINGS[["share"]]
SetClientFiles(SETTINGS[["certdir"]])
GetTestEnvironment(baseUrl = SETTINGS[["server"]],
token = tokenSuaB)
}
} else {
R_SWS_SHARE_PATH = "Z:"
SetClientFiles("/srv/shiny-server/.R/QA/")
GetTestEnvironment(baseUrl = "https://swsqa.aws.fao.org:8181",
token = tokenSuaB)
}
KeySUAbLive <- DatasetKey(domain = domainComm, dataset = datasetSUABlive, dimensions = list(
geographicAreaM49_fi = Dimension(name = "geographicAreaM49_fi", keys = sel_country),
measuredElementSuaFbs = Dimension(name = "measuredElementSuaFbs",
GetCodeList(domainComm, datasetFBSfrozen,"measuredElementSuaFbs" )[,code]),
measuredItemFaostat_L2 = Dimension(name = "measuredItemFaostat_L2",
GetCodeList(domainComm, datasetFBSfrozen,"measuredItemFaostat_L2" )[,code]),
timePointYears = Dimension(name = "timePointYears", keys = as.character(sel_years) )))
SUAblive2blank <- GetData(KeySUAbLive)
SUAblive2blank <- SUAblive2blank[ , c('Value', 'flagObservationStatus', 'flagMethod') := list(NA, NA, NA)]
SaveData(domain = domainComm,
dataset = datasetSUABlive,
data = SUAblive2blank,
waitTimeout = Inf)
SaveData(domain = domainComm,
dataset = datasetSUABlive,
data = SUAb,
waitTimeout = Inf)
message('SUA balanced live saved')
showModal(modalDialog(
title = "Updating dataset..." ,
sprintf("4/8")
))
#-- Save FBS Fias validated ----
if(localrun){
if(CheckDebug()){
library(faoswsModules)
SETTINGS = ReadSettings("sws.yml")
R_SWS_SHARE_PATH = SETTINGS[["share"]]
SetClientFiles(SETTINGS[["certdir"]])
GetTestEnvironment(baseUrl = SETTINGS[["server"]],
token = tokenFbsFiasval)
}
} else {
R_SWS_SHARE_PATH = "Z:"
SetClientFiles("/srv/shiny-server/.R/QA/")
GetTestEnvironment(baseUrl = "https://swsqa.aws.fao.org:8181",
token = tokenFbsFiasval)
}
KeyFbsFias <- DatasetKey(domain = domainComm, dataset = datasetFBSval, dimensions = list(
geographicAreaM49_fi = Dimension(name = "geographicAreaM49_fi", keys = sel_country),
measuredElementSuaFbs = Dimension(name = "measuredElementSuaFbs",
GetCodeList(domainComm, datasetFBSfrozen,"measuredElementSuaFbs" )[,code]),
measuredItemFaostat_L2 = Dimension(name = "measuredItemFaostat_L2",
GetCodeList(domainComm, datasetFBSfrozen,"measuredItemFaostat_L2" )[,code]),
timePointYears = Dimension(name = "timePointYears", keys = as.character(sel_years) )))
fbsFias2blank <- GetData(KeyFbsFias)
fbsFias2blank <- fbsFias2blank[ , c('Value', 'flagObservationStatus', 'flagMethod') := list(NA, NA, NA)]
SaveData(domain = domainComm,
dataset = datasetFBSval,
data = fbsFias2blank,
waitTimeout = Inf)
FBSfias$timePointYears <- as.character(FBSfias$timePointYears)
SaveData(domain = domainComm,
dataset = datasetFBSval,
data = FBSfias,
waitTimeout = Inf)
message('FBS Fias validated saved')
showModal(modalDialog(
title = "Updating dataset..." ,
sprintf("5/8")
))
#-- Save FBS Fias ----
if(localrun){
if(CheckDebug()){
library(faoswsModules)
SETTINGS = ReadSettings("sws.yml")
R_SWS_SHARE_PATH = SETTINGS[["share"]]
SetClientFiles(SETTINGS[["certdir"]])
GetTestEnvironment(baseUrl = SETTINGS[["server"]],
token = tokenFbs)
}
} else {
R_SWS_SHARE_PATH = "Z:"
SetClientFiles("/srv/shiny-server/.R/QA/")
GetTestEnvironment(baseUrl = "https://swsqa.aws.fao.org:8181",
token = tokenFbs)
}
KeyFbsFiasLive <- DatasetKey(domain = domainComm, dataset = datasetFBSlive, dimensions = list(
geographicAreaM49_fi = Dimension(name = "geographicAreaM49_fi", keys = sel_country),
measuredElementSuaFbs = Dimension(name = "measuredElementSuaFbs",
GetCodeList(domainComm, datasetFBSfrozen,"measuredElementSuaFbs" )[,code]),
measuredItemFaostat_L2 = Dimension(name = "measuredItemFaostat_L2",
GetCodeList(domainComm, datasetFBSfrozen,"measuredItemFaostat_L2" )[,code]),
timePointYears = Dimension(name = "timePointYears", keys = as.character(sel_years) )))
fbsFiaslive2blank <- GetData(KeyFbsFiasLive)
fbsFiaslive2blank <- fbsFiaslive2blank[ , c('Value', 'flagObservationStatus', 'flagMethod') := list(NA, NA, NA)]
SaveData(domain = domainComm,
dataset = datasetFBSlive,
data = fbsFiaslive2blank,
waitTimeout = Inf)
FBSfias$timePointYears <- as.character(FBSfias$timePointYears)
SaveData(domain = domainComm,
dataset = datasetFBSlive,
data = FBSfias,
waitTimeout = Inf)
message('FBS Fias live saved')
showModal(modalDialog(
title = "Updating dataset..." ,
sprintf("6/8")
))
#-- Save FBS Faostat validated ----
if(localrun){
if(CheckDebug()){
library(faoswsModules)
SETTINGS = ReadSettings("sws.yml")
R_SWS_SHARE_PATH = SETTINGS[["share"]]
SetClientFiles(SETTINGS[["certdir"]])
GetTestEnvironment(baseUrl = SETTINGS[["server"]],
token = tokenFbsFaostatval)
}
} else {
R_SWS_SHARE_PATH = "Z:"
SetClientFiles("/srv/shiny-server/.R/QA/")
GetTestEnvironment(baseUrl = "https://swsqa.aws.fao.org:8181",
token = tokenFbsFaostatval)
}
KeyFbsfaostat <- DatasetKey(domain = domainComm, dataset = datasetFBSfaostatval, dimensions = list(
geographicAreaM49_fi = Dimension(name = "geographicAreaM49_fi", keys = sel_country),
measuredElementSuaFbs = Dimension(name = "measuredElementSuaFbs",
GetCodeList(domainComm, datasetFBSfrozen,"measuredElementSuaFbs" )[,code]),
measuredItemFaostat_L2 = Dimension(name = "measuredItemFaostat_L2",
GetCodeList(domainComm, datasetFBSfrozen,"measuredItemFaostat_L2" )[,code]),
timePointYears = Dimension(name = "timePointYears", keys = as.character(sel_years) )))
fbsFaostat2blank <- GetData(KeyFbsfaostat)
fbsFaostat2blank <- fbsFaostat2blank[ , c('Value', 'flagObservationStatus', 'flagMethod') := list(NA, NA, NA)]
SaveData(domain = domainComm,
dataset = datasetFBSfaostatval,
data = fbsFaostat2blank,
waitTimeout = Inf)
FBSfaostat$timePointYears <- as.character(FBSfaostat$timePointYears)
SaveData(domain = domainComm,
dataset = datasetFBSfaostatval,
data = FBSfaostat,
waitTimeout = Inf)
message('FBS Faostat validated saved')
showModal(modalDialog(
title = "Updating dataset..." ,
sprintf("7/8")
))
#-- Save FBS Faostat -----
if(localrun){
if(CheckDebug()){
library(faoswsModules)
SETTINGS = ReadSettings("sws.yml")
R_SWS_SHARE_PATH = SETTINGS[["share"]]
SetClientFiles(SETTINGS[["certdir"]])
GetTestEnvironment(baseUrl = SETTINGS[["server"]],
token = tokenFbsFaostat)
}
} else {
R_SWS_SHARE_PATH = "Z:"
SetClientFiles("/srv/shiny-server/.R/QA/")
GetTestEnvironment(baseUrl = "https://swsqa.aws.fao.org:8181",
token = tokenFbsFaostat)
}
KeyFbsfaostatlive <- DatasetKey(domain = domainComm, dataset = datasetFBSfaostatlive, dimensions = list(
geographicAreaM49_fi = Dimension(name = "geographicAreaM49_fi", keys = sel_country),
measuredElementSuaFbs = Dimension(name = "measuredElementSuaFbs",
GetCodeList(domainComm, datasetFBSfrozen,"measuredElementSuaFbs" )[,code]),
measuredItemFaostat_L2 = Dimension(name = "measuredItemFaostat_L2",
GetCodeList(domainComm, datasetFBSfrozen,"measuredItemFaostat_L2" )[,code]),
timePointYears = Dimension(name = "timePointYears", keys = as.character(sel_years) )))
fbsFaostatlive2blank <- GetData(KeyFbsfaostat)
fbsFaostatlive2blank <- fbsFaostatlive2blank[ , c('Value', 'flagObservationStatus', 'flagMethod') := list(NA, NA, NA)]
SaveData(domain = domainComm,
dataset = datasetFBSfaostatlive,
data = fbsFaostatlive2blank,
waitTimeout = Inf)
SaveData(domain = domainComm,
dataset = datasetFBSfaostatlive,
data = FBSfaostat,
waitTimeout = Inf)
message('FBS Faostat live saved')
#-- The End ----
showModal(modalDialog(
title = "All datasets updated successfully!" ,
sprintf("Validated data are now saved into the SWS.
Please now save data directly into the SWS session.")
))
}
})
4.4 External functions
Most of the external functions of the shiny replicate what the plugin does but with separate functions in order to control better the input and output objects but also for the functions to be self-contained as they are used several times in the shiny. The functions recalled in the ‘SUAbalCalc’ functions: ‘eRcomputation’, ‘inputComputation’ and ‘foodProcessingComputation’ are the same used in the plugin. These functions are reported below for completeness purposes. For code-related explanation go to chapter (PluginCode). The new functions ‘reloadData’ and ‘reloadDataToken’ are explained in the corresponding paragraphs.
4.4.1 GPrecalc
GPrecalc <- function(GP, map_asfis, new_map_asfis, year = input$btn_year){
# Map to ICS
t1 <- Sys.time()
gpMap <- merge(GP, map_asfis, by = c("fisheriesAsfis"), all.x = TRUE)
if(nrow(new_map_asfis) > 0){
new_map_asfis[ end_year == 'LAST', end_year := as.character(year)]
newMapping <- merge(gpMap, new_map_asfis,
by.x = c('geographicAreaM49_fi', 'fisheriesAsfis'),
by.y = c('country', 'asfis'), all = TRUE, allow.cartesian = TRUE)
unchanged <- newMapping[is.na(from_code)]
unchanged <- rbind(unchanged, newMapping[!is.na(from_code) & timePointYears > end_year | timePointYears < start_year])
tochange <- newMapping[!is.na(from_code)]
tochange <- tochange[ , c('timePointYears', 'end_year', 'start_year') := list(as.numeric(timePointYears), as.numeric(end_year), as.numeric(start_year))]
tochange1 <- tochange[ timePointYears <= end_year & timePointYears >= start_year & ratio == 1]
tochange1 <- tochange1[, ics := to_code]
duplicate <- tochange[ timePointYears <= end_year & timePointYears >= start_year & ratio < 1]
# Allow for splitting
if(nrow(duplicate) > 0){
duplicate[ timePointYears <= end_year & timePointYears >= start_year & ratio != 1, c('ics', 'Value') := list(to_code, Value * as.numeric(ratio))]
duplicate[ , total := sum(as.numeric(ratio)), by = c('geographicAreaM49_fi', 'fisheriesAsfis', 'measuredElement', 'timePointYears','from_code', 'start_year', 'end_year')]
if(nrow(duplicate[total < 1]) > 0){
duplicate[ , diff := (1-total)]
addMissingQuantities <- duplicate[diff != 0, ]
addMissingQuantities[ , c('Value', 'ratio') := list(sum(Value), diff),
by = c('geographicAreaM49_fi', 'fisheriesAsfis', 'measuredElement',
'timePointYears', 'from_code', 'start_year', 'end_year')]
addMissingQuantities[ , c('Value', 'to_code', 'ics') := list((Value/total)*as.numeric(ratio), from_code, from_code)]
setkey(addMissingQuantities)
addMissingQuantities <- unique(addMissingQuantities)
duplicate <- rbind(duplicate, addMissingQuantities)
duplicate[ , diff := NULL]
}
duplicate[ , total := NULL]
}
changed <- rbind(tochange1, duplicate)
gpMap_new <- rbind(unchanged, changed)
gpMap_new[ , c('from_code', 'to_code', 'start_year', 'end_year', 'ratio'):= NULL]
} else {
gpMap_new <- gpMap
}
globalProductionAggr <- gpMap_new[, list(Value = sum(Value, na.rm = TRUE),
flagObservationStatus = max(flagObservationStatus),
flagMethod = "s"), by = list(geographicAreaM49_fi,
timePointYears,
measuredElement,
ics)]
globalProductionAggr <- globalProductionAggr[!is.na(ics), ]
t2 <- Sys.time()
message(paste("GP, okay", t2-t1))
return(globalProductionAggr)
}
4.4.2 CDBrecalc
CDBrecalc <- function(CDB, map_isscfc, new_map_isscfc, year = input$btn_year){
t1 <- Sys.time()
commodityDBIcs <- merge(CDB, map_isscfc, by = "measuredItemISSCFC")
commodityDBIcs$measuredItemISSCFC <- as.character(commodityDBIcs$measuredItemISSCFC)
old_map_isscfc <- ReadDatatable('cdb_mapping', where = paste("country = '", unique(commodityDBIcs$geographicAreaM49_fi), "'", sep = ''))
# If an updated has been done the the new datatable is used,
# otherwise if the CDB tab has not even been opened
# the current SWS datatable is used
if(nrow(new_map_isscfc) > 0){
new_map_isscfc <- new_map_isscfc
} else {
new_map_isscfc <- old_map_isscfc
}
# Account for commodity deviation
if(nrow(new_map_isscfc) > 0){
new_map_isscfc[ end_year == 'LAST', end_year := as.character(year)]
newMappingCDB <- merge(commodityDBIcs, new_map_isscfc,
by.x = c('geographicAreaM49_fi', 'measuredElement','measuredItemISSCFC'),
by.y = c('country', 'element','isscfc'), all = TRUE, allow.cartesian = TRUE)
unchangedCDB <- newMappingCDB[is.na(from_code)]
unchangedCDB <- rbind(unchangedCDB, newMappingCDB[!is.na(from_code) & timePointYears > end_year | timePointYears < start_year])
tochangeCDB <- newMappingCDB[!is.na(from_code)]
tochangeCDB <- tochangeCDB[ , c('timePointYears', 'end_year', 'start_year') := list(as.numeric(timePointYears), as.numeric(end_year), as.numeric(start_year))]
tochangeCDB1 <- tochangeCDB[ timePointYears <= end_year & timePointYears >= start_year & ratio == 1]
tochangeCDB1 <- tochangeCDB1[, ics := to_code]
duplicateCDB <- tochangeCDB[ timePointYears <= end_year & timePointYears >= start_year & ratio < 1]
# Allow for splitting
if(nrow(duplicateCDB) > 0){
duplicateCDB[ timePointYears <= end_year & timePointYears >= start_year & ratio != 1, c('ics', 'Value') := list(to_code, Value * as.numeric(ratio))]
duplicateCDB[ , total := sum(ratio), by = c('geographicAreaM49_fi', 'measuredItemISSCFC', 'measuredElement', 'timePointYears','from_code', 'start_year', 'end_year')]
if(nrow(duplicateCDB[total < 1]) > 0){
duplicateCDB[ , diff := (1-total)]
addMissingQuantitiesCDB <- duplicateCDB[diff != 0, ]
addMissingQuantitiesCDB[ , c('Value', 'ratio') := list(sum(Value), diff),
by = c('geographicAreaM49_fi', 'measuredItemISSCFC', 'measuredElement',
'timePointYears', 'from_code', 'start_year', 'end_year')]
addMissingQuantitiesCDB[ , c('Value', 'to_code', 'ics') := list((Value/total)*as.numeric(ratio), from_code, from_code)]
setkey(addMissingQuantitiesCDB)
addMissingQuantitiesCDB <- unique(addMissingQuantitiesCDB)
duplicateCDB <- rbind(duplicateCDB, addMissingQuantitiesCDB)
duplicateCDB[ , diff := NULL]
}
duplicateCDB[ , total := NULL]
}
changedCDB <- rbind(tochangeCDB1, duplicateCDB)
cdbMap_new <- rbind(unchangedCDB, changedCDB)
cdbMap_new <- rbind(unchangedCDB, changedCDB[ics != '9999']) # 9999 is a code when the production of the commodity does not have to be considered
cdbMap_new[ , c('from_code', 'to_code', 'start_year', 'end_year', 'ratio'):= NULL]
# Sum by ICS, no commodities anymore
} else {
cdbMap_new <- commodityDBIcs
}
# Link table for special period ICS group changes
link_table <- ReadDatatable("link_table")
## Checks on link table
# quantity different from 100% allocated
link_table[ , check := sum(percentage), by=c("geographic_area_m49","flow","start_year","end_year","from_code")]
linkCorrespondence <- ReadDatatable('link_table_elements')
setnames(linkCorrespondence, old = 'measuredelement', new = 'measuredElement')
link_table2 <- merge(link_table, linkCorrespondence, by = "flow", allow.cartesian = TRUE)
if(max(as.numeric(cdbMap_new$timePointYears)) == -Inf){
yearmax<- year
} else {yearmax<- max(as.numeric(cdbMap_new$timePointYears))}
link_table2$end_year <- ifelse(link_table2$end_year == "LAST", yearmax,
link_table2$end_year)
link_table2 <- link_table2[end_year >= as.character(start_year)]
years <- expand.grid(as.character(1:nrow(link_table2)), 1948:year)
years <- as.data.table(years)
setnames(years, c('Var1','Var2'), c('idx', 'timePointYears'))
link_table2[ , idx := row.names(link_table2) ]
link_table3 <- merge(link_table2,
years, by = 'idx')
link_table3 <- link_table3[timePointYears >= start_year & timePointYears <= end_year]
link_table3[ , idx := NULL]
link_table3[ ,timePointYears := as.character(timePointYears)]
# Change ICS codes
message('From table to CDB')
commodityDBLink <- merge(cdbMap_new, link_table3,
by.x = c("geographicAreaM49_fi", "measuredElement", "timePointYears", "ics"),
by.y = c("geographic_area_m49", "measuredElement", "timePointYears","from_code"),
all.x = TRUE, allow.cartesian = TRUE)
setkey(commodityDBLink)
commodityDBLink <- unique(commodityDBLink)
# Avoid NAs for periods
commodityDBLink$start_year <- ifelse(is.na(commodityDBLink$start_year), "1900", commodityDBLink$start_year)
commodityDBLink$end_year <- ifelse(is.na(commodityDBLink$end_year), "9999", commodityDBLink$end_year)
# commodityDBLink <- commodityDBLink[timePointYears >= start_year, ]
# commodityDBLink <- commodityDBLink[timePointYears <= end_year]
# Change ICS for defined periods
commodityDBLink[!is.na(to_code) &
as.numeric(timePointYears) >= as.numeric(start_year) &
as.numeric(timePointYears) <= as.numeric(end_year), ics := to_code]
commodityDBLink[!is.na(percentage) , Value := Value*percentage]
# remove unnecessary dimensions
commodityDBLink <- commodityDBLink[ , c("flow", "start_year", "end_year", "percentage", "to_code", "check") := NULL]
# Some commodities are not imported for food porpuses (e.g. "ornamental fish").
# Those flow are deviated to "other utilizations"
otherUses <- ReadDatatable('other_uses')
commodityDBotherUses <- merge(commodityDBLink, otherUses,
by.x = c( "measuredItemISSCFC", "measuredElement", "ics"),
by.y = c("isscfc", "measured_element_orig", "ics"))
commodityDBotherUses$measuredElement <- ifelse(is.na(commodityDBotherUses$measured_element_dest),
commodityDBotherUses$measuredElement,
commodityDBotherUses$measured_element_dest)
commodityDBotherUses <- commodityDBotherUses[ , c("label", "measured_element_dest", "fias_code") := NULL]
commodityDBdeviated <- rbind(commodityDBLink, commodityDBotherUses)
commodityDBAggr <- commodityDBdeviated[ , list(Value = sum(Value, na.rm = TRUE),
flagObservationStatus = max(flagObservationStatus),
flagMethod = "s"),
by = list(geographicAreaM49_fi,
timePointYears,
measuredElement,
ics)]
tradeQ <- commodityDBAggr[measuredElement %in% c('5910', '5610')]
tradeV <- commodityDBAggr[measuredElement %in% c('5922', '5622')]
tradeQ[measuredElement == '5910', flow := 'EXP']
tradeQ[measuredElement == '5610', flow := 'IMP']
tradeV[measuredElement == '5922', flow := 'EXP']
tradeV[measuredElement == '5622', flow := 'IMP']
if(nrow(tradeQ) > 0){
tradeUV <- merge(tradeQ, tradeV, by = c('geographicAreaM49_fi',
'timePointYears',
'flow',
'ics'), all = T,
suffixes = c('Q', 'V'))
tradeUV <- tradeUV[, c('Value', 'flagObservationStatus', 'flagMethod') :=
list(ValueV/ValueQ, flagObservationStatusV, "c")]
tradeUV[flow == 'IMP', measuredElement := '5630' ]
tradeUV[flow == 'EXP', measuredElement := '5930' ]
tradeUV[is.nan(Value), Value := 0]
tradeUV[ValueQ == 0, Value := ValueV]
commodityDBAggrTot <- rbind(commodityDBAggr[!measuredElement %in% c('5930', '5630')],
tradeUV[,.(geographicAreaM49_fi,
timePointYears,
measuredElement,
ics, Value,
flagObservationStatus,
flagMethod)])
} else {
commodityDBAggrTot <- commodityDBAggr
}
t2 <- Sys.time()
message(paste("CDB, okay", t2-t1))
return(commodityDBAggrTot)
}
4.4.3 SUAunbalCalc
SUAunbalCalc <- function(globalProductionAggr, commodityDBAggr){
t1 <- Sys.time()
SUA <- rbind(globalProductionAggr, commodityDBAggr)
yearVals <- unique(SUA$timePointYears)
setnames(SUA, "ics", "measuredItemFaostat_L2")
SUA <- SUA[ , list(Value = sum(Value, na.rm = TRUE),
flagObservationStatus = max(flagObservationStatus),
flagMethod = "s"), by = list(geographicAreaM49_fi,
timePointYears,
measuredElement,
measuredItemFaostat_L2)]
setnames(SUA, 'measuredElement', 'measuredElementSuaFbs')
SUA <- SUA[!is.na(Value)]
elementSignTable <- ReadDatatable('element_sign_table')
setnames(elementSignTable, 'measured_element', 'measuredElementSuaFbs')
# Now not considering food processing (as in plugin FP calculated later)
SUAexpanded <- merge(SUA[measuredElementSuaFbs != "5023"],
elementSignTable[ , .(measuredElementSuaFbs, sign)],
by = "measuredElementSuaFbs", all.x = TRUE)
SUAexpanded[, availability := sum(Value * sign, na.rm = TRUE),
by = list(geographicAreaM49_fi, timePointYears, measuredItemFaostat_L2)]
initialUnbal <- SUAexpanded[availability < 0]
t2 <- Sys.time()
message(paste("SUA unbal, okay", t2-t1))
return(list(SUAunbal = SUA,
initialUnbal = initialUnbal))
}
4.4.4 SUAbalCalc
The function includes the same ‘eRcomputation’, ‘inputComputation’ and ‘foodProcessingComputation’ functions as those described in chapter (PluginCode)
SUAbalCalc <- function(SUA, eR, use){
t1 <- Sys.time()
SUAno131 <- SUA[ measuredElementSuaFbs != "5023"]
SUA131 <- SUA[ measuredElementSuaFbs == "5023"]
elementSignTable <- ReadDatatable('element_sign_table')
setnames(elementSignTable, 'measured_element', 'measuredElementSuaFbs')
# Now only considering production, import and export to compute availability
# then after calculations we compare official food processing data with calculations
SUAexpanded <- merge(SUAno131, elementSignTable[ , .(measuredElementSuaFbs, sign)], by = "measuredElementSuaFbs", all.x = TRUE)
SUAexpanded[, availability := sum(Value * sign, na.rm = TRUE),
by = list(geographicAreaM49_fi, timePointYears, measuredItemFaostat_L2)]
# Check no negative primary availability.
# Now many production data are missing in the commodity DB in SWS so
# there are negative primary availabilities
map_asfis <- ReadDatatable('map_asfis')
setnames(map_asfis, c("asfis", "ics"), c("fisheriesAsfis", "measuredItemFaostat_L2"))
primary <- unique(map_asfis$measuredItemFaostat_L2)
primaryneg <- SUAexpanded[availability < 0 & measuredItemFaostat_L2 %in% primary]
if(nrow(primaryneg) > 0){
countriesneg <- unique(primaryneg[ , .(geographicAreaM49_fi, measuredItemFaostat_L2, timePointYears)])
msgg <- apply(countriesneg,1, paste0, collapse = ', ')
msg2email4 <- paste0('There are negative primary availabilities. Check (country code, product code, year): ',
paste0(msgg, collapse = " and "))
message(msg2email4)
} else {
msg2email4 <- ''
}
rou <- copy(primaryneg)
rou[ , c('measuredElementSuaFbs',
'Value',
'flagObservationStatus',
'flagMethod', 'sign') := list('5166', availability,
'I', 'i', -1)]
setkey(rou)
rou <- unique(rou)
SUAexpanded <- rbind(SUAexpanded, rou)
secondaryneg0 <- SUAexpanded[availability < 0 & !measuredItemFaostat_L2 %in% primary]
setkey(secondaryneg0)
secondaryneg0 <- unique(secondaryneg0)
yearVals <- as.character(min(unique(as.numeric(as.character(SUAexpanded$timePointYears)))):max(unique(as.numeric(as.character(SUAexpanded$timePointYears)))))
# Delete old imbalances stored
imbalance_store <- ReadDatatable('imbalance_tab', readOnly = FALSE)
if(nrow(imbalance_store[ geographicaream49_fi %in% unique(secondaryneg0$geographicAreaM49_fi) &
timepointyears %in% yearVals, ]) > 0){
changeset <- Changeset('imbalance_tab')
AddDeletions(changeset, imbalance_store[ geographicaream49_fi %in% unique(secondaryneg0$geographicAreaM49_fi) & timepointyears %in% yearVals, ])
Finalise(changeset)
}
# Add new imbalances
secondarynegCompliant <- copy(secondaryneg0)
secondarynegCompliant <- secondarynegCompliant[ , .(geographicAreaM49_fi, measuredItemFaostat_L2,
timePointYears, availability)]
setkey(secondarynegCompliant)
secondarynegCompliant <- unique(secondarynegCompliant)
setnames(secondarynegCompliant,
c('geographicAreaM49_fi', 'timePointYears',
'measuredItemFaostat_L2'),
c('geographicaream49_fi', 'timepointyears',
'measureditemfaostat_l2'))
changeset <- Changeset('imbalance_tab')
AddInsertions(changeset, secondarynegCompliant)
Finalise(changeset)
if(nrow(secondaryneg0) > 0){
countriessecneg <- unique(secondaryneg0[ , .(geographicAreaM49_fi, measuredItemFaostat_L2, timePointYears)])
msgg2 <- apply(countriessecneg,1, paste0, collapse = ', ')
msg2email5 <- paste0('There are still negative secondary availabilities. Check (country code, product code, year): : ',
paste0(msgg2, collapse = " and "))
message(msg2email5)
} else {
msg2email5 <- ''
}
mealCodes <- GetCodeList("FisheriesCommodities",
"fi_sua_balanced_legacy",
"measuredItemFaostat_L2")[ grepl('meals', description)]$code
if(any(secondaryneg0$measuredItemFaostat_L2 %in% mealCodes)){
mealsUnbal <- secondaryneg0[measuredItemFaostat_L2 %in% mealCodes]
message('Unbalance for meal products!')
secondaryneg <- secondaryneg0[!measuredItemFaostat_L2 %in% mealCodes]
} else {
secondaryneg <- secondaryneg0
}
rouMeals <- copy(secondaryneg0[measuredItemFaostat_L2 %in% mealCodes])
rouMeals[ , c('measuredElementSuaFbs',
'Value',
'flagObservationStatus',
'flagMethod', 'sign') := list('5166', availability,
'I', 'i', -1)]
setkey(rouMeals)
rouMeals <- unique(rouMeals)
if(nrow(secondaryneg) > 0){
# Make sure all production (5510) values have been imputed
icsneg <- unique(secondaryneg$measuredItemFaostat_L2)
setkey(secondaryneg, geographicAreaM49_fi, timePointYears, measuredItemFaostat_L2, availability)
prod2add <- unique(secondaryneg[ , .(geographicAreaM49_fi, timePointYears, measuredItemFaostat_L2, availability) ])
# add production element with NA values and flags then estimate as in Francesca code with estimation flags
prod2add[ , ':=' (measuredElementSuaFbs = '5510', Value = - availability,
flagObservationStatus = as.factor('I'), flagMethod = 'i', sign = 1)]
# SUA with all production values
SUAwithProdupd <- merge(secondaryneg, prod2add, by = c('geographicAreaM49_fi',
'timePointYears',
'measuredItemFaostat_L2',
'availability',
'measuredElementSuaFbs'),
suffixes = c('', '_added'), all = TRUE)
SUAwithProdupd$sign_added <- as.integer(SUAwithProdupd$sign_added)
SUAwithProdupd[measuredElementSuaFbs == '5510' , c("Value", "sign",
"flagObservationStatus",
"flagMethod") := list(ifelse(is.na(Value), Value_added,
Value+Value_added),
sign_added,
flagObservationStatus_added,
flagMethod_added)]
# Putting together values with negative and positive availability which had been separated before
SUAcomplement <- SUAexpanded[!secondaryneg, on = names(secondaryneg)]
SUAcomplement <- rbind(SUAcomplement, rouMeals)
# Putting together values with negative and positive availability which had been separated before
SUAwithProd <- rbind(SUAwithProdupd[ , .(geographicAreaM49_fi, timePointYears,
measuredItemFaostat_L2, availability,
measuredElementSuaFbs, Value,
flagObservationStatus, flagMethod, sign)],
SUAcomplement)
# SUAwithProd[ , sign := NULL ]
} else {
SUAwithProd <- SUAexpanded
# SUAwithProd[ , sign := NULL ]
}
SUAwithProd[, availability := sum(Value * sign, na.rm = TRUE),
by = list(geographicAreaM49_fi, timePointYears, measuredItemFaostat_L2)]
SUAwithProd[ , sign := NULL]
tree <- ReadDatatable('fi_commodity_tree')
treePrim <- copy(tree)
treePrim <- treePrim[parent %in% primary ]
yearVals <- as.character(min(unique(as.numeric(as.character(SUAwithProd$timePointYears)))):max(unique(as.numeric(as.character(SUAwithProd$timePointYears)))))
SUAvalEr <- SUAwithProd[measuredElementSuaFbs == '5423' & timePointYears != max(yearVals)]
FPproblems <- list()
if(nrow(SUAwithProd[!measuredItemFaostat_L2 %in% primary]) > 0){
message("fi_SUA-FBS: Calculating extraction rates")
SUAwithEr <- eRcomputation(data = SUAwithProd,
tree = treePrim,
primary = primary,
oldEr = SUAvalEr, years = yearVals)
# If updating extraction rates
if(use == 1){
SUAnewEr <- merge(SUAwithEr, eR, by = c('geographicAreaM49_fi',
'measuredItemFaostat_L2',
'measuredElementSuaFbs',
'timePointYears'), all.x = TRUE,
suffixes = c('','New'))
SUAnewEr[measuredElementSuaFbs == '5423', Value := ifelse(!is.na(ValueNew) & Value != ValueNew, ValueNew, Value)]
SUAnewEr[ , c('ValueNew', 'flagObservationStatusNew', 'flagMethodNew'):=NULL]
}
else {
SUAnewEr <- copy(SUAwithEr)
}
message("fi_SUA-FBS: Calculating input element")
SUAinput <- inputComputation(data = SUAnewEr, primary = primary, use)
newTree <- merge(tree, unique(SUAinput[ measuredElementSuaFbs == '5423' & !is.na(Value),
.(geographicAreaM49_fi, timePointYears, measuredItemFaostat_L2, Value)]),
by.x = 'child', by.y = 'measuredItemFaostat_L2', all.x = TRUE, allow.cartesian = TRUE)
newTree[ , extraction_rate := Value ]
newTree[ , Value:= NULL]
#--Food processing ----
message("fi_SUA-FBS: Calculating food processing")
FPdata_alltest <- foodProcessingComputation(SUAinput = SUAinput,
treeNewER = newTree, primary = primary)
FPdatatest <- FPdata_alltest$result
FPdatatest <- FPdatatest[Value != 0]
FPproblemstest <- list()
FPproblemstest <- FPdata_alltest$problems
###########
# Change of input to calculate FP for problematic data ----
# Get problematic groups
if(any(sapply(FPproblemstest, nrow)>0)){
avoidProblems <- rbindlist(FPproblemstest, fill = TRUE)
avoidProblems <- unique(avoidProblems[ , .(geographicAreaM49_fi,
timePointYears,
parent_primary)])
# Parent-child tree
treeneeded0 <- data.table(parent = unique(avoidProblems$parent_primary),
child = unique(avoidProblems$parent_primary))
treeneeded <- unique(newTree[parent %in% unique(avoidProblems$parent_primary), .(parent, child) ])
treeneeded <- rbind(treeneeded, treeneeded0)
# Get complete structure of problematic groups
avoidProblems2 <- merge(avoidProblems, treeneeded,
by.x = 'parent_primary',
by.y = 'parent', all.x = TRUE,
allow.cartesian = TRUE)
setnames(avoidProblems2, 'child', 'measuredItemFaostat_L2')
# The problematic groups with food are recalculated without food
SUAnoFood0 <- SUAinput[measuredElementSuaFbs != '5141' ]
SUAnoFood <- merge(SUAnoFood0, elementSignTable[ , .(measuredElementSuaFbs, sign)], by = "measuredElementSuaFbs", all.x = TRUE)
SUAnoFood[, availability := sum(Value * sign, na.rm = TRUE),
by = list(geographicAreaM49_fi, timePointYears, measuredItemFaostat_L2)]
SUAnoFood[ , sign := NULL]
subst <- merge(SUAnoFood, avoidProblems2[ , .(geographicAreaM49_fi,
timePointYears,
measuredItemFaostat_L2)],
by = c("geographicAreaM49_fi",
"timePointYears",
"measuredItemFaostat_L2"))
# The part that was okay with food is recalculated without the problematic part
cancel <- merge(SUAinput, avoidProblems2[ , .(geographicAreaM49_fi,
timePointYears,
measuredItemFaostat_L2)],
by = c("geographicAreaM49_fi",
"timePointYears",
"measuredItemFaostat_L2"))
SUAinputcan <- SUAinput[!cancel, on = names(SUAinput)]
if(nrow(SUAinputcan) > 0){
FPdata_all1 <- foodProcessingComputation(SUAinput = SUAinputcan,
treeNewER = newTree, primary = primary)
FPdata1 <- FPdata_all1$result
FPdata1 <- FPdata1[Value != 0]
FPproblems1 <- list(primary = data.table(),
secondaryTot = data.table(),
secondary = data.table(),
tertiary = data.table(),
quaternary = data.table(),
NotCovered = data.table())
FPproblems1 <- FPdata_all1$problems
} else {
FPdata1 <- data.table()
FPproblems1 <- list(primary = data.table(),
secondaryTot = data.table(),
secondary = data.table(),
tertiary = data.table(),
quaternary = data.table(),
NotCovered = data.table())
}
# FP calculated for problematic elements
FPdata_all2 <- foodProcessingComputation(SUAinput = subst,
treeNewER = newTree,
primary = primary)
FPdata2 <- FPdata_all2$result
FPdata2 <- FPdata2[Value != 0]
FPproblems2 <- list(primary = data.table(),
secondaryTot = data.table(),
secondary = data.table(),
tertiary = data.table(),
quaternary = data.table(),
NotCovered = data.table())
FPproblems2 <- FPdata_all2$problems
# Put together results and dataset to consider
FPdata <- rbind(FPdata1, FPdata2)
FPproblems <- FPproblems2
SUAnoFP <- rbind(SUAinputcan, subst)
} else {SUAnoFP <- SUAinput
FPdata <- FPdatatest
FPproblems <- list(primary = data.table(),
secondaryTot = data.table(),
secondary = data.table(),
tertiary = data.table(),
quaternary = data.table(),
NotCovered = data.table())}
message('Food re-processing okay')
FPdata <- FPdata[ , availability := NULL ]
FPdata[ , c("flagObservationStatus", "flagMethod") := list("E", "i")]
SUAnoFP[ , availability := NULL]
# If processing value changed in the shiny, i.e. flagged as (E,f)
# then value flagged (E,f) prevail on the computed one
FPdataupd <- merge(SUA131, FPdata, by = c('geographicAreaM49_fi', 'measuredItemFaostat_L2',
'timePointYears', 'measuredElementSuaFbs'),
all = TRUE, suffixes = c('', 'Recalc'))
# FPdataupd[is.na(Value) | flagMethodRecalc == 'f', c('Value',
# 'flagObservationStatus',
# 'flagMethod') := list(ValueRecalc,
# flagObservationStatusRecalc,
# flagMethodRecalc)]
FPdataupd[!is.na(ValueRecalc), c('Value',
'flagObservationStatus',
'flagMethod') := list(ValueRecalc,
flagObservationStatusRecalc,
flagMethodRecalc)]
FPdataupd[ , c('ValueRecalc',
'flagObservationStatusRecalc',
'flagMethodRecalc') := NULL]
SUAunbal <- rbind(SUAnoFP[!is.na(Value), ], FPdataupd[!is.na(Value), ])
SUAunbal$flagObservationStatus <- as.character(SUAunbal$flagObservationStatus)
} else {
SUAunbal <- SUAwithProd[!is.na(Value), ]
}
# R_SWS_SHARE_PATH <- Sys.getenv("R_SWS_SHARE_PATH")
#
# saveRDS(FPproblems,
# file.path(R_SWS_SHARE_PATH, "taglionic", "FPfisheries", "FoodProcessingFeedback.rds")
# )
if(length(FPproblems) > 0 & exists('FPproblems$NotCovered')){
if(nrow(FPproblems$NotCovered) > 0){
uncovered <- copy(FPproblems$NotCovered)
uncovered[ , measuredElementSuaFbs := '5023']
setnames(uncovered, c('parent_primary', 'UncoveredQuantity'),
c('measuredItemFaostat_L2', 'Value'))
rouUncovered <-copy(uncovered)
rouUncovered[ , measuredElementSuaFbs := '5166']
rouUncovered[ , Value := -Value]
uncoveredAdjusted <- rbind(uncovered, rouUncovered)
uncoveredAdjusted[ , c("flagObservationStatus", "flagMethod") := list("E", "i")]
uncoveredAdjusted[ measuredElementSuaFbs == '5166' , c("flagObservationStatus", "flagMethod") := list("I", "i")]
}
} else {
uncoveredAdjusted <- data.table()
}
SUAunbal <- rbind(SUAunbal, uncoveredAdjusted)
SUAunbal$flagObservationStatus <- factor(SUAunbal$flagObservationStatus, levels = c('M', 'O', 'N', '', 'X', 'T', 'E', 'I'), ordered = TRUE)
SUAunbal <- SUAunbal[ , list(Value = sum(Value, na.rm = TRUE),
flagObservationStatus = max(flagObservationStatus),
flagMethod = 's'),
by = c("geographicAreaM49_fi", "timePointYears",
"measuredItemFaostat_L2", "measuredElementSuaFbs")]
setkey(SUAunbal)
SUAunbal <- unique(SUAunbal)
#-- Balancing ----
SUAunbal <- merge(SUAunbal, elementSignTable[, .(measuredElementSuaFbs, sign)], by = "measuredElementSuaFbs", all.x = TRUE)
SUAunbal$timePointYears <- as.character(SUAunbal$timePointYears)
SUAunbal <- SUAunbal[measuredElementSuaFbs != '645']
if(any(is.na(SUAunbal$sign))){
message(paste(SUAunbal[is.na(SUAunbal$sign), ],
' is an element in the SUA not included in the availability calculation.'))
}
SUAunbal[, availability := sum(Value * sign, na.rm = TRUE),
by = list(geographicAreaM49_fi, timePointYears, measuredItemFaostat_L2)]
balancingElements <- ReadDatatable('balancing_elements')
setnames(balancingElements, names(balancingElements), c("geographicAreaM49_fi",
"measuredItemFaostat_L2",
"measuredElementSuaFbs",
"start_year", "end_year", "share"))
balancingElements[ end_year == "LAST"]$end_year <- as.character(max(unique(as.numeric(SUAunbal$timePointYears))))
balancingValues <- unique(SUAunbal[ , .(geographicAreaM49_fi, timePointYears , measuredItemFaostat_L2, availability) ])
balancing <- merge(balancingElements,
balancingValues, by = c("geographicAreaM49_fi","measuredItemFaostat_L2"),
all.y = TRUE)
setnames(balancing, c("availability"), c("Value"))
if(any(is.na(balancing$measuredElementSuaFbs)) & any(balancing[is.na(measuredElementSuaFbs)]$availability != 0)){
message('Balancing elements missing!')
message(balancing[is.na(measuredElementSuaFbs) & availability != 0])
}
balancing2merge <- balancing[ as.numeric(timePointYears) >= as.numeric(start_year) & as.numeric(timePointYears) <= as.numeric(end_year), Value := Value*share]
balancing2merge[ , c('start_year', 'end_year', 'share') := NULL]
balancing2merge[ , c('flagObservationStatus', 'flagMethod') := list('E','b')]
# Balancing cannot be negative
balancingproblems <- balancing2merge[round(Value,6) < 0,]
balancingproblems_store <- ReadDatatable('balancing_problems_tab', readOnly = FALSE)
# Store balancing problems
balancingproblems_store <- ReadDatatable('balancing_problems_tab', readOnly = FALSE)
if(nrow(balancingproblems_store[ geographicaream49_fi %in% unique(SUAunbal$geographicAreaM49_fi) &
timepointyears %in% yearVals, ]) > 0){
changeset <- Changeset('balancing_problems_tab')
AddDeletions(changeset, balancingproblems_store[ geographicaream49_fi %in% unique(SUAunbal$geographicAreaM49_fi) & timepointyears %in% yearVals, ])
Finalise(changeset)
}
# Add new imbalances
if(length(FPproblems) > 0 & exists('FPproblems$NotCovered')){
if(nrow(FPproblems$NotCovered) > 0){
toupload <- copy(FPproblems$NotCovered)
toupload[ , measuredElementSuaFbs := '5023']
setnames(toupload, c('parent_primary', 'UncoveredQuantity'),
c('measuredItemFaostat_L2', 'Value'))
balancingproblemsCompliant <- rbind(toupload, balancingproblems[ , .(geographicAreaM49_fi, measuredItemFaostat_L2,
timePointYears, measuredElementSuaFbs, Value)])
}
} else {
balancingproblemsCompliant <- rbind(balancingproblems[ , .(geographicAreaM49_fi, measuredItemFaostat_L2,
timePointYears, measuredElementSuaFbs, Value)])
}
if(nrow(balancingproblemsCompliant) > 0){
setkey(balancingproblemsCompliant)
balancingproblemsCompliant <- unique(balancingproblemsCompliant)
setnames(balancingproblemsCompliant,
c('geographicAreaM49_fi', 'timePointYears',
'measuredItemFaostat_L2', 'measuredElementSuaFbs', 'Value'),
c('geographicaream49_fi', 'timepointyears',
'measureditemfaostat_l2', 'measuredelementsuafbs', 'value'))
changeset <- Changeset('balancing_problems_tab')
AddInsertions(changeset, balancingproblemsCompliant)
Finalise(changeset)
}
# SUAbal1 <- rbind(SUAunbal[ , .(geographicAreaM49_fi, timePointYears ,
# measuredItemFaostat_L2, measuredElementSuaFbs,
# Value, flagObservationStatus, flagMethod)], balancing2merge)
# # Sum if there is a balancing elements that was already present there
# if negative balancing element then balance imbalance with 5166
balancingimb <- copy(balancing2merge[Value < 0])
balancingimb <- balancingimb[Value < 0, c('measuredElementSuaFbs',
'flagObservationStatus',
'flagMethod') := list('5166', 'I', 'i')]
balancingimb[ , Value := Value]
balancingTot <- rbind(balancing2merge[Value > 0], balancingimb)
SUAbal <- merge(SUAunbal[ , .(geographicAreaM49_fi, timePointYears ,
measuredItemFaostat_L2, measuredElementSuaFbs,
Value, flagObservationStatus, flagMethod)],
balancingTot,
by = c('geographicAreaM49_fi', 'timePointYears',
'measuredItemFaostat_L2', 'measuredElementSuaFbs'),
suffixes = c('','Bal'),
all = TRUE)
SUAbal[is.na(ValueBal), ValueBal := 0 ]
SUAbal[is.na(Value), Value := 0]
SUAbal[ , Value := Value + ValueBal ]
SUAbal$flagObservationStatus <- as.character(SUAbal$flagObservationStatus)
SUAbal[is.na(flagObservationStatus) , flagObservationStatus := 'E']
SUAbal[is.na(flagMethod) , flagMethod := 'b']
SUAbal <- SUAbal[ , c('ValueBal',
'flagObservationStatusBal',
'flagMethodBal') := NULL]
tradeQ <- SUAbal[measuredElementSuaFbs %in% c('5910', '5610')]
tradeV <- SUAbal[measuredElementSuaFbs %in% c('5922', '5622')]
tradeQ[measuredElementSuaFbs == '5910', flow := 'EXP']
tradeQ[measuredElementSuaFbs == '5610', flow := 'IMP']
tradeV[measuredElementSuaFbs == '5922', flow := 'EXP']
tradeV[measuredElementSuaFbs == '5622', flow := 'IMP']
if(nrow(tradeQ) > 0){
tradeUV <- merge(tradeQ, tradeV, by = c('geographicAreaM49_fi',
'timePointYears',
'flow',
'measuredItemFaostat_L2'), all = T,
suffixes = c('Q', 'V'))
tradeUV <- tradeUV[, c('Value', 'flagObservationStatus', 'flagMethod') :=
list(ValueV/ValueQ, flagObservationStatusV, "c")]
tradeUV[flow == 'IMP', measuredElementSuaFbs := '5630' ]
tradeUV[flow == 'EXP', measuredElementSuaFbs := '5930' ]
tradeUV[is.nan(Value), Value := 0]
tradeUV[ValueQ == 0, Value := ValueV]
SUAbal <- rbind(SUAbal[!measuredElementSuaFbs %in% c('5630','5930')], tradeUV[,.(geographicAreaM49_fi,
timePointYears,
measuredElementSuaFbs,
measuredItemFaostat_L2,
Value,
flagObservationStatus,
flagMethod)])
}
SUAbalAvail <- merge(SUAbal, elementSignTable[, .(measuredElementSuaFbs, sign)], by = "measuredElementSuaFbs", all.x = TRUE)
SUAbalAvail[, availability := sum(Value * sign, na.rm = TRUE),
by = list(geographicAreaM49_fi, timePointYears, measuredItemFaostat_L2)]
if(any(round(SUAbalAvail$availability) != 0)){
msg2email7 <- paste0('Problem with products:',
paste0(unique(SUAbalAvail[round(availability) != 0, ]$measuredItemFaostat_L2), collapse = ", "))
message(paste("fi_SUA-FBS: Balancing was not successful for some products. ", msg2email7, sep = ''))
} else {
msg2email7 <- ''
}
SUAbalAvail[, c("sign", "availability"):=NULL]
t2 <- Sys.time()
message(paste("SUAbal, okay", t2-t1))
list( NegAv = secondaryneg,
FPproblems = FPproblems,
SUA = SUAbalAvail,
msg = list(msg1 = msg2email4, msg2 = msg2email5, msg3 = msg2email7))
}
4.4.5 SUAnutrCalc
SUAnutrCalc <- function(SUAbalAvail, popSWS){
t1 <- Sys.time()
## Add NutrientFactors
nutrientFactors <- ReadDatatable("fishery_nutrient")
nutrientFactors$calories <- as.numeric(nutrientFactors$calories)
nutrientFactors$proteins <- as.numeric(nutrientFactors$proteins)
nutrientFactors$fats <- as.numeric(nutrientFactors$fats)
nutrientFactors[is.na(proteins), proteins := 0]
SUA_with_nutrient <- merge(SUAbalAvail, nutrientFactors, by.x = "measuredItemFaostat_L2", by.y = "ics", all.x = TRUE)
SUA_with_nutrient[measuredElementSuaFbs=="5141", calories:=Value*calories/100]
SUA_with_nutrient[measuredElementSuaFbs=="5141", proteins:=Value*proteins/100]
SUA_with_nutrient[measuredElementSuaFbs=="5141", fats:=Value*fats/100]
SUA_with_nutrient[measuredElementSuaFbs!="5141",`:=`(c("calories", "proteins", "fats"),list(0,0,0) )]
# Get "calories", "proteins" and "fats" and make them in the dataset format
SUAnutrients <- melt.data.table(SUA_with_nutrient[measuredElementSuaFbs=="5141", ],
id.vars = c('geographicAreaM49_fi', 'measuredItemFaostat_L2', 'timePointYears'),
measure.vars = c('calories', 'proteins','fats'),
variable.name = 'measuredElementSuaFbs', value.name = 'Value')
SUAnutrients$measuredElementSuaFbs <- as.character(SUAnutrients$measuredElementSuaFbs)
SUAnutrients$measuredElementSuaFbs <- ifelse(SUAnutrients$measuredElementSuaFbs == 'calories', '261',
ifelse(SUAnutrients$measuredElementSuaFbs == 'proteins', '271',
ifelse(SUAnutrients$measuredElementSuaFbs == 'fats', '281', SUAnutrients$measuredElementSuaFbs)))
SUAnutrients[ , c('flagObservationStatus', 'flagMethod') := list('E','i')]
SUAnutrients <- unique(SUAnutrients)
food <- SUA_with_nutrient[measuredElementSuaFbs=="5141", .(measuredItemFaostat_L2, measuredElementSuaFbs,
geographicAreaM49_fi, timePointYears, Value,
flagObservationStatus, flagMethod)]
SUAnutrients <- rbind(SUAnutrients, food)
SUAnutrientCapita <- merge(SUAnutrients, popSWS, by=c("geographicAreaM49_fi","timePointYears"),
suffixes = c("","_pop"))
SUAnutrientCapita[measuredElementSuaFbs !="5141" , Value := (Value*1000)/(Value_pop*365)]
SUAnutrientCapita[measuredElementSuaFbs =="5141" , Value := Value/Value_pop]
SUAnutrientCapita <- SUAnutrientCapita[ , .(geographicAreaM49_fi,
timePointYears,
measuredItemFaostat_L2,
measuredElementSuaFbs,
Value, flagObservationStatus,
flagMethod)]
SUAnutrientCapita[measuredElementSuaFbs=="261",measuredElementSuaFbs:="264"]
SUAnutrientCapita[measuredElementSuaFbs=="281",measuredElementSuaFbs:="284"]
SUAnutrientCapita[measuredElementSuaFbs=="271",measuredElementSuaFbs:="274"]
SUAnutrientCapita[measuredElementSuaFbs=="5141",measuredElementSuaFbs:="645"]
SUA_with_nutrient[ , c('calories', 'proteins','fats') := NULL]
# bind SUA with "calories", "proteins" and "fats" elements
SUAallNutr <- rbind(SUAnutrients[measuredElementSuaFbs!="5141"], SUAnutrientCapita)
SUANoPop <- rbind(SUA_with_nutrient, SUAallNutr)
Pop2include <- merge(unique(SUANoPop[ , .(measuredItemFaostat_L2,
geographicAreaM49_fi,
timePointYears)]), popSWS, by = c('geographicAreaM49_fi',
'timePointYears'))
SUA2save <- rbind(SUANoPop[measuredElementSuaFbs != '645'], Pop2include)
t2 <- Sys.time()
message(paste("SUAnut, okay", t2-t1))
return(list(SUA2save = SUA2save, foodPercapita = SUANoPop[measuredElementSuaFbs == '645']))
}
4.4.6 FBScalc
FBScalc <- function(SUA2save, popSWS){
t1 <- Sys.time()
# get all conversion factors (or extration rates) from commodity tree
message('Get commodity tree')
tree <- ReadDatatable('fi_commodity_tree')
primary <- unique(tree[!parent %in% child]$parent)
extrRates <- unique(SUA2save[ measuredElementSuaFbs == '5423', .(measuredItemFaostat_L2, geographicAreaM49_fi, timePointYears, Value)])
compareEr <- merge(unique(tree[parent %in% primary , .(child, extraction_rate)]), extrRates, by.x = 'child', by.y = 'measuredItemFaostat_L2', all.y = TRUE)
compareEr[is.na(Value), Value := extraction_rate]
updatedEr <- compareEr[ , .(child, Value, geographicAreaM49_fi, timePointYears)]
updatedtree <- merge(unique(tree[parent %in% primary , .(parent, child, weight)]), updatedEr, by= 'child', all.y = TRUE, allow.cartesian = TRUE)
setkey(updatedtree)
convFact <- unique(updatedtree[weight == TRUE & !is.na(Value) , .(geographicAreaM49_fi, timePointYears, parent, child, Value)])
# For primary product add conversion factor equal 1
primaryTree1 <- data.table(geographicAreaM49_fi = rep(unique(SUA2save$geographicAreaM49_fi), each = length(unique(SUA2save$timePointYears))),
timePointYears = rep(unique(SUA2save$timePointYears), length(unique(SUA2save$geographicAreaM49_fi))) )
primaryTree2 <- data.table(geographicAreaM49_fi = rep(unique(SUA2save$geographicAreaM49_fi), each = length(unique(primary))), parent = primary)
primaryTree <- merge(primaryTree1, primaryTree2, by = 'geographicAreaM49_fi', allow.cartesian = TRUE)
primaryTree[ , `:=` (child = parent, Value = 1)]
convFact <- rbind(convFact, primaryTree)
setnames(convFact, new = 'extraction_rate', old = 'Value')
# SUA with standardized element, no zero weight elements
SUAstand_prep <- merge(SUA2save, convFact, by.x = c('geographicAreaM49_fi', 'timePointYears', 'measuredItemFaostat_L2'),
by.y = c('geographicAreaM49_fi', 'timePointYears', 'child'))
SUAstand_prep <- SUAstand_prep[!is.na(Value)]
setkey(SUAstand_prep)
SUAstand_prep <- unique(SUAstand_prep)
# Standardised value is Value/eR except from input values which are already in primary equivalent
SUAstand_prep[! measuredElementSuaFbs %in% c('5302', '261', '264', '271', '274', '281', '284', '511'), Value_stand := Value/extraction_rate]
SUAstand_prep[measuredElementSuaFbs %in% c('5302', '261', '264', '271', '274', '281', '284', '511'), Value_stand := Value]
# take only all primary elements and for secondary exclude production and input
SUAstand <- rbind(SUAstand_prep[measuredItemFaostat_L2 %in% primary, ],
SUAstand_prep[!measuredElementSuaFbs %in% c('5510', '5302') & !measuredItemFaostat_L2 %in% primary, ])
##-- FAOSTAT ----
# Aggregate SUA by parent meals included for FAOSTAT
SUAstandAggr0 <- SUAstand[ , .(measuredElementSuaFbs, geographicAreaM49_fi, timePointYears,
flagObservationStatus, flagMethod, parent, Value_stand)]
# SUAstandAggr0$flagObservationStatus <- factor(SUAstandAggr0$flagObservationStatus, levels = c('M', 'O', 'N', '', 'X', 'T', 'E', 'I'), ordered = TRUE)
SUAstandAggr <- SUAstandAggr0[measuredElementSuaFbs != '511' , list(Value = sum(Value_stand, na.rm = TRUE),
flagObservationStatusAggr = 'I',
flagMethodAggr = 's'), by = c("measuredElementSuaFbs", "geographicAreaM49_fi",
"timePointYears", "parent")]
setnames(SUAstandAggr, c('parent', 'flagObservationStatusAggr', 'flagMethodAggr'),
c('measuredItemFaostat_L2', 'flagObservationStatus', 'flagMethod'))
# Pop2SUAaggr <- SUAstandAggr0[measuredElementSuaFbs == '511']
# setkey(Pop2SUAaggr)
# Pop2SUAaggr <- unique(Pop2SUAaggr)
# setnames(Pop2SUAaggr, c('Value_stand', 'parent'), c('Value', 'measuredItemFaostat_L2'))
# SUAstandAggr <- rbind(SUAstandAggr1, Pop2SUAaggr)
IcsGroups <- unique(SUAstandAggr[ , .(geographicAreaM49_fi, timePointYears, measuredItemFaostat_L2)])
faostat_pop2merge <- merge(IcsGroups, popSWS, by=c("geographicAreaM49_fi","timePointYears"), all = TRUE)
faostatfbsPOP <- rbind(SUAstandAggr, faostat_pop2merge)
# mapp for FBS groups
sua_fbs_mapping <- ReadDatatable('faostatl2_to_faostatl1')
setnames(sua_fbs_mapping, 'measureditemfaostat_l2', 'measuredItemFaostat_L2' )
sua_fbs_mapping[ , label := NULL]
fbsFaostatL1faostat <- merge(faostatfbsPOP, sua_fbs_mapping, by = "measuredItemFaostat_L2")
fbsFaostatL1faostat[ , measuredItemFaostat_L2 := NULL]
setnames(fbsFaostatL1faostat, "fbs", "measuredItemFaostat_L2")
#-- FAOSTAT FBS standardization ----
message("Starting Faostat standardization")
faostatGroups <- ReadDatatable('fi_faostat_standardization_element')
setnames(faostatGroups, c('measuredelementsuafbs', 'measuredelementfaostat'), c('measuredElementSuaFbs', 'measuredElementFaostat'))
FBSfaostat0 <- merge(fbsFaostatL1faostat[!measuredElementSuaFbs %in% c('261', '271', '281')],
faostatGroups, by = "measuredElementSuaFbs")
FBSfaostat1 <- FBSfaostat0[measuredElementFaostat != '511' , list(Value = sum(Value, na.rm = TRUE),
flagObservationStatus = 'I',
flagMethod = 's'), by = c("geographicAreaM49_fi",
"timePointYears", "measuredItemFaostat_L2",
"faostat", "measuredElementFaostat")]
FBSfaostat <- rbind(FBSfaostat1, FBSfaostat0[measuredElementFaostat == '511', -'measuredElementSuaFbs', with = FALSE])
setnames(FBSfaostat, c("faostat", "measuredElementFaostat"), c("element_description", "measuredElementSuaFbs"))
faostatFBS2save <- FBSfaostat[ , .(geographicAreaM49_fi, timePointYears, measuredItemFaostat_L2,
measuredElementSuaFbs, Value, flagObservationStatus, flagMethod)]
faostatFBS2save <- faostatFBS2save[!is.na(Value)]
#-- FIAS ----
# Aggregate SUA by parent code take away meals
mealCodes <- GetCodeList("FisheriesCommodities",
"fi_sua_balanced_legacy",
"measuredItemFaostat_L2")[ grepl('meals', description)]$code
# SUA with elements and groups to aggregates
SUAstandAggrFias0 <- SUAstand[ !measuredItemFaostat_L2 %in% mealCodes , .(measuredElementSuaFbs, geographicAreaM49_fi, timePointYears,
flagObservationStatus, flagMethod, parent, Value_stand)]
# take only input element 5302
mealsInput0 <- SUA2save[measuredElementSuaFbs == '5302' & measuredItemFaostat_L2 %in% mealCodes , .(measuredElementSuaFbs, geographicAreaM49_fi, timePointYears,
flagObservationStatus, flagMethod,
measuredItemFaostat_L2, Value)]
mealsInput <- merge(mealsInput0, unique(tree[parent %in% primary, .(parent, child)]),
by.x = 'measuredItemFaostat_L2', by.y = 'child', all.x = TRUE)
mealsInput[ , measuredItemFaostat_L2 := NULL]
setnames(mealsInput, c("parent"), c("measuredItemFaostat_L2"))
# SUAstandAggrFias0$flagObservationStatus <- factor(SUAstandAggrFias0$flagObservationStatus, levels = c('M', 'O', 'N', '', 'X', 'T', 'E', 'I'), ordered = TRUE)
SUAstandAggrFias <- SUAstandAggrFias0[measuredElementSuaFbs != '511' , list(Value = sum(Value_stand, na.rm = TRUE),
flagObservationStatusAggr = 'I',
flagMethodAggr = 's'), by = c("measuredElementSuaFbs", "geographicAreaM49_fi",
"timePointYears", "parent")]
setnames(SUAstandAggrFias, c('parent', 'flagObservationStatusAggr', 'flagMethodAggr'),
c('measuredItemFaostat_L2', 'flagObservationStatus', 'flagMethod'))
# Pop2SUAaggFias <- SUAstandAggrFias0[measuredElementSuaFbs == '511']
# setkey(Pop2SUAaggFias)
# Pop2SUAaggFias <- unique(Pop2SUAaggFias)
# setnames(Pop2SUAaggFias,c('Value_stand', 'parent'), c('Value', 'measuredItemFaostat_L2'))
# SUAstandAggrFias <- rbind(SUAstandAggrFias1, Pop2SUAaggFias)
fiasFbsTot <- rbind(SUAstandAggrFias, mealsInput)
IcsGroups <- unique(fiasFbsTot[ , .(geographicAreaM49_fi, timePointYears, measuredItemFaostat_L2)])
# Introduce population data
pop2merge <- merge(popSWS, IcsGroups, by = c("geographicAreaM49_fi", "timePointYears"), all = TRUE)
fiasfbsPOP <- rbind(fiasFbsTot, pop2merge)
# mapp for FBS groups
sua_fbs_mapping <- ReadDatatable('faostatl2_to_faostatl1')
setnames(sua_fbs_mapping, 'measureditemfaostat_l2', 'measuredItemFaostat_L2' )
sua_fbs_mapping[ , label := NULL]
fbsFaostatL1 <- merge(fiasfbsPOP, sua_fbs_mapping, by = "measuredItemFaostat_L2")
fbsFaostatL1[ , measuredItemFaostat_L2 := NULL]
setnames(fbsFaostatL1, "fbs", "measuredItemFaostat_L2")
#-- FIAS FBS standardization ----
message("fi_SUA-FBS: Starting Fias standardization")
fiasGroups <- ReadDatatable('fi_fias_standardization_element')
setnames(fiasGroups, c('measuredelementsuafbs', 'measuredelementfias'), c('measuredElementSuaFbs', 'measuredElementFias'))
# FBS
FBSfias0 <- merge(fbsFaostatL1[!measuredElementSuaFbs %in% c('261', '271', '281')],
fiasGroups, by = "measuredElementSuaFbs")
FBSfias1 <- FBSfias0[measuredElementFias != '511' , list(Value = sum(Value, na.rm = TRUE),
flagObservationStatus = 'I',
flagMethod = 's'), by = c("geographicAreaM49_fi",
"timePointYears", "measuredItemFaostat_L2",
"fias", "measuredElementFias")]
FBSfias <- rbind(FBSfias1, FBSfias0[measuredElementFias == '511', -'measuredElementSuaFbs', with = FALSE])
fiasFBS2save <- FBSfias[, .(geographicAreaM49_fi, timePointYears, measuredItemFaostat_L2,
measuredElementFias, Value, flagObservationStatus, flagMethod)]
setnames(fiasFBS2save, "measuredElementFias", "measuredElementSuaFbs")
t2 <- Sys.time()
message(paste("FBS, okay", t2-t1))
#-- To update ----
return(list(faostat = faostatFBS2save, fias = fiasFBS2save))
}
4.4.7 reloadData
The ‘reloadData’ and ‘reloadDataToken’ functions are sister functions. Their purpose is to check if the dataset required by the shiny has already been loaded or if it needs to be loaded for the first time or again because the parameters have changed. The difference between the two is that the ‘reloadData’ function pulls data saved in the dataset whereas the ‘reloadDataToken’ pulls data saved in a session and hence needs the specific token of the session. The function works in this way: it checks the row of the object where the data should be (‘data’). If the object is empty it gets the data from the SWS. If the object is not empty, it checks the years selected and the chosen country if they are not the same as those of the selected objects it reloads the data with the right parameters. If none of the condition is true then the function return a null object and the data object remain the one already loaded. In order to avoid problems with the dimensions all of them are specified in the arguments along with the domain and the dataset name.
reloadData <- function(data, keycountry, minyear, maxyear, keydomain, keydataset,
keygeo = 'geographicAreaM49_fi', keytime = 'timePointYears',
keyelement= 'measuredElementSuaFbs',
keyitem = 'measuredItemFaostat_L2'){
sel_years <- as.character(as.numeric(minyear):as.numeric(maxyear))
if(nrow(data) == 0){
Key <- DatasetKey(domain = keydomain,
dataset = keydataset,
dimensions = list(geographicAreaM49_fi = Dimension(name = keygeo, keys = keycountry),
measuredElementSuaFbs = Dimension(name = keyelement,
GetCodeList(keydomain,
keydataset,
keyelement )[,code]),
measuredItemFaostat_L2 = Dimension(name = keyitem,
GetCodeList(keydomain,
keydataset,
keyitem )[,code]),
timePointYears = Dimension(name = keytime, keys = sel_years )))
withProgress(message = 'Data loading in progress',
value = 0, {
Sys.sleep(0.25)
incProgress(0.25)
dataKey <- GetData(Key)
Sys.sleep(0.75)
incProgress(0.95)
})
data <- dataKey
return(data)
} else if(nrow(data) > 0 &
unique(data$geographicAreaM49_fi) != keycountry |
min(unique(data$timePointYears)) != minyear |
max(unique(data$timePointYears)) != maxyear){
Key <- DatasetKey(domain = keydomain,
dataset = keydataset,
dimensions = list(geographicAreaM49_fi = Dimension(name = keygeo, keys = keycountry),
measuredElementSuaFbs = Dimension(name = keyelement,
GetCodeList(keydomain,
keydataset,
keyelement )[,code]),
measuredItemFaostat_L2 = Dimension(name = keyitem,
GetCodeList(keydomain,
keydataset,
keyitem )[,code]),
timePointYears = Dimension(name = keytime, keys = sel_years )))
withProgress(message = 'Data loading in progress',
value = 0, {
Sys.sleep(0.25)
incProgress(0.25)
dataKey <- GetData(Key)
Sys.sleep(0.75)
incProgress(0.95)
})
data <- dataKey
return(data)
} else {data <- NULL}
}
4.4.8 reloadDataToken
The ‘reloadDataToken’ function has the same structure as the previous one but, in addition, it has a token argument allowing to get data from the wanted SWS session.
reloadDataToken <- function(data, keycountry, minyear, maxyear, keydomain, keydataset, keytoken,
keygeo = 'geographicAreaM49_fi', keytime = 'timePointYears',
keyelement= 'measuredElementSuaFbs',
keyitem = 'measuredItemFaostat_L2'){
sel_years <- as.character(as.numeric(minyear):as.numeric(maxyear))
if(nrow(data) == 0){
if(localrun){
if(CheckDebug()){
library(faoswsModules)
SETTINGS = ReadSettings("sws.yml")
R_SWS_SHARE_PATH = SETTINGS[["share"]]
SetClientFiles(SETTINGS[["certdir"]])
GetTestEnvironment(baseUrl = SETTINGS[["server"]],
token = keytoken)
}
} else {
R_SWS_SHARE_PATH = "Z:"
SetClientFiles("/srv/shiny-server/.R/QA/")
GetTestEnvironment(baseUrl = "https://swsqa.aws.fao.org:8181",
token = keytoken)
}
Key <- DatasetKey(domain = keydomain,
dataset = keydataset,
dimensions = list(geographicAreaM49_fi = Dimension(name = keygeo, keys = keycountry),
measuredElementSuaFbs = Dimension(name = keyelement,
GetCodeList(keydomain,
keydataset,
keyelement )[,code]),
measuredItemFaostat_L2 = Dimension(name = keyitem,
GetCodeList(keydomain,
keydataset,
keyitem )[,code]),
timePointYears = Dimension(name = keytime, keys = sel_years )))
withProgress(message = 'Data loading in progress',
value = 0, {
Sys.sleep(0.25)
incProgress(0.25)
dataKey <- GetData(Key)
Sys.sleep(0.75)
incProgress(0.95)
})
data <- dataKey
return(data)
} else if(nrow(data) > 0 &
unique(data$geographicAreaM49_fi) != keycountry |
min(unique(data$timePointYears)) != minyear |
max(unique(data$timePointYears)) != maxyear){
if(localrun){
if(CheckDebug()){
library(faoswsModules)
SETTINGS = ReadSettings("sws.yml")
R_SWS_SHARE_PATH = SETTINGS[["share"]]
SetClientFiles(SETTINGS[["certdir"]])
GetTestEnvironment(baseUrl = SETTINGS[["server"]],
token = keytoken)
}
} else {
R_SWS_SHARE_PATH = "Z:"
SetClientFiles("/srv/shiny-server/.R/QA/")
GetTestEnvironment(baseUrl = "https://swsqa.aws.fao.org:8181",
token = keytoken)
}
Key <- DatasetKey(domain = keydomain,
dataset = keydataset,
dimensions = list(geographicAreaM49_fi = Dimension(name = keygeo, keys = keycountry),
measuredElementSuaFbs = Dimension(name = keyelement,
GetCodeList(keydomain,
keydataset,
keyelement )[,code]),
measuredItemFaostat_L2 = Dimension(name = keyitem,
GetCodeList(keydomain,
keydataset,
keyitem )[,code]),
timePointYears = Dimension(name = keytime, keys = sel_years )))
withProgress(message = 'Data loading in progress',
value = 0, {
Sys.sleep(0.25)
incProgress(0.25)
dataKey <- GetData(Key)
Sys.sleep(0.75)
incProgress(0.95)
})
data <- dataKey
return(data)
} else {data <- NULL}
}