Commit fabefd4c authored by vbaudrot's avatar vbaudrot

fix bug tick >65

parent b0cb0168
Pipeline #1644 canceled with stages
in 1 minute and 43 seconds
compare_slope_WORLD_analysis_f = function(x,data.popS,targets)
{
compare_slope_WORLD_analysis_f = function(x,data.popS,country_forecast) {
popS=rep(NA,nrow(x))
for(i in 1:nrow(x)){
popS[i]=data.popS$popS[data.popS[,1]==x[i,1] & data.popS[,2]==x[i,2]]
}
Countries=paste(x[,1],x[,2],sep="_")[!is.na(popS)]
CountriesFR=x[,2]
CountriesFR[x[,1]!=""]=paste(x[x[,1]!="",2],x[x[,1]!="",1],sep=", ")
CountriesFR=CountriesFR[!is.na(popS)]
Popsize=popS[!is.na(popS)]
Shortname=paste(casefold(substr(CountriesFR,1,3),upper=TRUE),1:length(CountriesFR),sep="")
data.frame(CountriesFR,Popsize/10^6)
......@@ -20,7 +19,6 @@ compare_slope_WORLD_analysis_f = function(x,data.popS,targets)
yy=rbind(yy,x[Regions%in%Countries[i],])
}
classement.countries=order(yy[,ncol(yy)]/Popsize,decreasing=TRUE)
yy=yy[classement.countries,]
......@@ -31,6 +29,9 @@ compare_slope_WORLD_analysis_f = function(x,data.popS,targets)
Shortname=Shortname[classement.countries]
cbind(Popsize/10^6,yy)[1:30,1:6]
#############
targets = which(CountriesFR %in% country_forecast)
#############
remove.date=0 ## Change this if you want to take an earlier date 'tau' at which data are stoped (e.g. remove.date=3 means that tau = the last observation date minus 3 days)
......@@ -44,7 +45,7 @@ compare_slope_WORLD_analysis_f = function(x,data.popS,targets)
## use of parametric model 1 (see empiric.trend1() fct) as a predictor
# model1 = FALSE
#for(targets in (5:nrow(yy))){
# for(targets in (5:nrow(yy))){
#if(yy[targets,ncol(yy)]>50){
bench0=1:(targets-1)
filter=((yy[bench0,ncol(yy)]/Popsize[bench0])/(yy[targets,ncol(yy)]/Popsize[targets])>
......@@ -88,13 +89,13 @@ compare_slope_WORLD_analysis_f = function(x,data.popS,targets)
## run prediction analyses
#for(ii in 1:length(targets)){
ii = 1
#print(c(targets[ii],length(benchmarks)))
countryFocal=Countries[targets[ii]]
countryFocalFR=CountriesFR[targets[ii]]
namefileFocal=Shortname[targets[ii]]
colorFocal="red"
popsizeFocal=Popsize[targets[ii]]
#try(source("compare-slope-GENERIC.R"))
#print(c(targets[ii],length(benchmarks)))
countryFocal=Countries[targets[ii]]
countryFocalFR=CountriesFR[targets[ii]]
namefileFocal=Shortname[targets[ii]]
colorFocal="red"
popsizeFocal=Popsize[targets[ii]]
#try(source("compare-slope-GENERIC.R"))
#}
#}
#}
......
library(parallel)
# detectCores()
listFigure_runFunction = function(possible_country_forecast,
possible_country_forecast_save,
listFigure_runFunction = function(x,
possible_country_forecast,
# possible_country_forecast_save,
list.popS,
model1 = FALSE, sizeTimeSeries = 100, mc.cores = 2){
# x=x
# possible_country_forecast = possible_country_forecast
# possible_country_forecast_save = possible_country_forecast_save
# list.popS = list.popS
list_figures = mclapply(possible_country_forecast,
function(country_forecast){
data.popS = list.popS[[country_forecast]]
cat(paste(country_forecast, "model1 =", model1))
# ii = which(possible_country_forecast %in% country_forecast)
# source(file = "compare_slope_EU_analysis_f.R")
# list_global = compare_slope_EU_analysis_f(x,ii)
targets = which(possible_country_forecast_save %in% country_forecast)
print(targets)
# targets = which(possible_country_forecast_save %in% country_forecast)
# print(targets)
test_init = try({
list_global = compare_slope_WORLD_analysis_f(x,data.popS, targets)
list_global = compare_slope_WORLD_analysis_f(x, data.popS, country_forecast)
list_global = compare_slope_GENERIC_f(list_global)
list_global = compare_slope_generic_main_f(list_global)
### plot whithout forecasting
......@@ -45,11 +57,21 @@ listFigure_runFunction = function(possible_country_forecast,
return(list_figures)
}
listFigure_runFunctionLAPPLY = function(possible_country_forecast,
listFigure_runFunctionLAPPLY = function(x,
possible_country_forecast,
possible_country_forecast_save,
list.popS,
model1 = FALSE, sizeTimeSeries = 100, mc.cores = NULL){
# x=x
# possible_country_forecast = possible_country_forecast
# possible_country_forecast_save = possible_country_forecast_save
# list.popS = list.popS
list_figures = lapply(possible_country_forecast,
function(country_forecast){
data.popS = list.popS[[country_forecast]]
cat(paste(country_forecast, "model1 =", model1))
# ii = which(possible_country_forecast %in% country_forecast)
# source(file = "compare_slope_EU_analysis_f.R")
......@@ -90,47 +112,6 @@ listFigure_runFunctionLAPPLY = function(possible_country_forecast,
}
listFigure_runFunction_loop = function(possible_country_forecast, sizeTimeSeries = 100){
list_figures = list()
for ( country_forecast in possible_country_forecast){
print(paste(country_forecast, "model1 = FALSE"))
# ii = which(possible_country_forecast %in% country_forecast)
# source(file = "compare_slope_EU_analysis_f.R")
# list_global = compare_slope_EU_analysis_f(x,ii)
targets = which(possible_country_forecast_save %in% country_forecast)
print(targets)
test_init = try({
list_global = compare_slope_WORLD_analysis_f(x,data.popS, targets)
list_global = compare_slope_GENERIC_f(list_global)
list_global = compare_slope_generic_main_f(list_global)
### plot whithout forecasting
list_global = compare_slope_generic_plotly_f(list_global)
list_global = compare_slope_generic_predict_f(list_global, model1 = FALSE)
### plot whith forecasting
list_global = compare_slope_generic_plotlybis_f(list_global, model1 = FALSE)
})
# } else{test_model0 = test_init}
if(class(test_init) != "try-error") {
# Reduce time line
for(i in 1:length(list_global$y_trans)){
list_global$y_trans[[i]] = list_global$y_trans[[i]][seq(1,length(list_global$y_trans[[i]]), length.out = sizeTimeSeries)]
list_global$date_trans[[i]] = list_global$date_trans[[i]][seq(1,length(list_global$date_trans[[i]]), length.out = sizeTimeSeries)]
}
list_global$dateTot = list_global$dateTot[seq(1,length(list_global$dateTot), length.out = sizeTimeSeries)]
list_global$yTot = list_global$yTot[seq(1,length(list_global$yTot), length.out = sizeTimeSeries)]
list_global$temp0 = list_global$temp0[seq(1,length(list_global$temp0), length.out = sizeTimeSeries)]
list_global$Qinf = list_global$Qinf[seq(1,length(list_global$Qinf), length.out = sizeTimeSeries)]
list_global$Qsup = list_global$Qsup[seq(1,length(list_global$Qsup), length.out = sizeTimeSeries)]
list_figures[[country_forecast]] = list_global
}
}
return(list_figures)
}
possibleCountryForecast = function(x, data.popS){
popS = rep(NA, nrow(x))
for (i in 1:nrow(x)) {
......
......@@ -36,6 +36,7 @@ statesUSA=read.table("USstates.txt",header=TRUE,sep=",",stringsAsFactors=FALSE,q
x=complement.USA(x,rawUSA,statesUSA)
## resolve a few issues with missing values or outlier values
x=correct.decrease(x)
x_forecast = x
# Add a country: https://population.un.org/wpp/Download/Standard/Population/
# data.popS = rbind(data.popS, c("", "Lesotho", 2142252))
......@@ -48,10 +49,15 @@ data.popS = readRDS("popsizes.rds")
source(file = "main_forecast_addFunction.R")
possible_country_forecast = possibleCountryForecast(x, data.popS)$possible_country_forecast
possible_country_forecast_save = possibleCountryForecast(x, data.popS)$possible_country_forecast_save
possible_country_forecast65 = possibleCountryForecast(x, data.popS65)$possible_country_forecast
possible_country_forecast_save65 = possibleCountryForecast(x, data.popS65)$possible_country_forecast_save
possible_country_forecast = possibleCountryForecast(x = x_forecast,
data.popS)$possible_country_forecast
possible_country_forecast_save = possibleCountryForecast(x = x_forecast,
data.popS)$possible_country_forecast_save
# possible_country_forecast65 = possibleCountryForecast(x = x_forecast,
# data.popS65)$possible_country_forecast
# possible_country_forecast_save65 = possibleCountryForecast(x = x_forecast,
# data.popS65)$possible_country_forecast_save
### Update once a day, it takes approximately one hour
......@@ -65,42 +71,72 @@ source(file = "compare_slope_generic_plotlybis_f.R")
############################################################
# TEST: ONLY 4 COUNNTRIES
#
# possible_country_forecast = possible_country_forecast[1:4]
possible_country_forecast = possible_country_forecast[1:4]
# possible_country_forecast65 = possible_country_forecast65[1:4]
possible_country_forecast = c("Brazil", "France")
# possible_country_forecast65 = c("Brazil", "France")
#
#
############################################################
#
# PREPARE DATA SET OF POPULATION SIZE
#
dfPops = dplyr::full_join(data.popS, data.popS65, by = c("Province.State", "Country.Region"), suffix = c(".all", ".65")) %>%
dplyr::mutate(country_forecast_popS = ifelse(Province.State == "", Country.Region, paste(Country.Region, Province.State, sep=", ")))
lsPops_all = lapply(possible_country_forecast,
function(country_forecast){
dplyr::mutate(dfPops, popS = popS.all)
})
names(lsPops_all) = possible_country_forecast
# list_figures_model0 = listFigure_runFunctionLAPPLY(possible_country_forecast,
# possible_country_forecast_save,
# model1 = FALSE, sizeTimeSeries = 100)
# list_figures_model1 = listFigure_runFunctionLAPPLY(possible_country_forecast,
# possible_country_forecast_save,
# model1 = TRUE, sizeTimeSeries = 100)
lsPops_65 = lapply(possible_country_forecast,
function(country_forecast){
dplyr::mutate(dfPops, popS = ifelse(country_forecast_popS != country_forecast, popS.65, popS.all))
})
names(lsPops_65) = possible_country_forecast
############################################################
#
# RUN FORECASTING
#
list_figures_model0 = list()
list_figures_model1 = list()
list_figures_model0_65 = list()
list_figures_model1_65 = list()
if( model_choice == "all" || model_choice == "0" ){
list_figures_model0 = listFigure_runFunction(possible_country_forecast,
possible_country_forecast_save,
list_figures_model0 = listFigure_runFunction(x = x_forecast,
possible_country_forecast,
# possible_country_forecast_save,
list.popS = lsPops_all,
model1 = FALSE, sizeTimeSeries = 100, mc.cores = 3)
}
if( model_choice == "all" || model_choice == "1" ){
list_figures_model1 = listFigure_runFunction(possible_country_forecast,
possible_country_forecast_save,
model1 = TRUE, sizeTimeSeries = 100, mc.cores = 3)
list_figures_model1 = listFigure_runFunction(x = x_forecast,
possible_country_forecast,
# possible_country_forecast_save,
list.popS = lsPops_all,
model1 = TRUE, sizeTimeSeries = 100, mc.cores = 3)
}
if( model_choice == "all" || model_choice == "2" ){
# >65 years old pop
list_figures_model0_65 = listFigure_runFunction(possible_country_forecast65,
possible_country_forecast_save65,
list_figures_model0_65 = listFigure_runFunction(x = x_forecast,
# possible_country_forecast65,
# possible_country_forecast_save65,
possible_country_forecast,
# possible_country_forecast_save,
list.popS = lsPops_65,
model1 = FALSE, sizeTimeSeries = 100, mc.cores = 3)
}
if( model_choice == "all" || model_choice == "3" ){
list_figures_model1_65 = listFigure_runFunction(possible_country_forecast65,
possible_country_forecast_save65,
model1 = TRUE, sizeTimeSeries = 100, mc.cores = 3)
list_figures_model1_65 = listFigure_runFunction(x = x_forecast,
possible_country_forecast,
# possible_country_forecast_save,
list.popS = lsPops_65,
model1 = TRUE, sizeTimeSeries = 100, mc.cores = 3)
}
if( model_choice == "merge" ) {
......@@ -114,8 +150,6 @@ if( model_choice == "merge" ) {
list_figures_model1_65 = list_figures$list_figures_model1_65
list_figures = list(
# possible_country_forecast = possible_country_forecast,
# possible_country_forecast65 = possible_country_forecast65,
list_figures_model0 = list_figures_model0,
list_figures_model1 = list_figures_model1,
list_figures_model0_65 = list_figures_model0_65,
......@@ -124,8 +158,6 @@ if( model_choice == "merge" ) {
saveRDS(object = list_figures, file = "list_figures.rds")
} else{
list_figures = list(
# possible_country_forecast = possible_country_forecast,
# possible_country_forecast65 = possible_country_forecast65,
list_figures_model0 = list_figures_model0,
list_figures_model1 = list_figures_model1,
list_figures_model0_65 = list_figures_model0_65,
......
......@@ -111,7 +111,6 @@ x = data.frame(dataDEATH)
# possible_country_forecast = c('Sweden','Ireland','Portugal','Denmark','Germany','Austria','Romania','Poland')
list_figures <- readRDS(file = "www/list_figures.rds")
possible_country_forecast = names(list_figures$list_figures_model0)
possible_country_forecast65 = names(list_figures$list_figures_model0_65)
### select one country to forecast
# country_forecast = 'Ireland'
# ii = which(possible_country_forecast %in% country_forecast)
......
......@@ -313,11 +313,11 @@ server <- function(input, output, session){
observe({
req(input$focalCountry_1)
output$plotWithForecast_1 <- renderPlotly({
# ii = which(possible_country_forecast %in% input$focalCountry_1)
if(input$zoomIn %% 2){ #odd number
final_plotly_f(list_figuresPLOT()[[input$focalCountry_1]], model1 = model1())
final_plotly_f(list_figuresPLOT(), model1 = model1())
} else{
final_plotly_f(list_figuresPLOT()[[input$focalCountry_1]], model1 = model1()) %>%
final_plotly_f(list_figuresPLOT()[[input$focalCountry_1]], model1 = model1()) %>%
layout(xaxis = list(
autorange = TRUE
),
......
......@@ -105,15 +105,11 @@ ui <- dashboardPage(
status = "success",
solidHeader = TRUE,
column(width = 3,
# checkboxInput("paramPredict_model1",
# "Add Parametric Predicator",
# value = FALSE),
checkboxGroupInput(inputId = "paramPredict",
label = "Model parameters",
choices = list("Parametric predictor" = "model1",
"Over 65 years old" = "over65"),
selected = NULL),
selected = NULL)
),
column(width = 5,
# uiOutput("selectFocalCountry")
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment