From dca55efaf3bf2f7476886fe27fd4762ce528a3ca Mon Sep 17 00:00:00 2001 From: nemeth Date: Tue, 9 Feb 2021 12:15:56 +0100 Subject: [PATCH] added multi-year selection --- app.R | 153 +++++++++++++++++++++++++++++++++++++++------------------- 1 file changed, 104 insertions(+), 49 deletions(-) diff --git a/app.R b/app.R index cd481e7..47088a3 100644 --- a/app.R +++ b/app.R @@ -312,18 +312,31 @@ tags$p(style="text-align:center;margin-bottom:0px;", inline = TRUE, selected=c("b","f","m") ), + radioButtons(inputId="viewlength", label="Reference period", choices=c("Continuous", "Multi-year"), selected="Continuous", inline=TRUE), - sliderInput(inputId="period", - label=HTML('Reference period','',as.character(icon("info", class="infoletter")),' Based on this period (target year included) different levels of the selected measure can be calculated. The difference between the result of this calculation and the target year is displayed in the figure. '), + conditionalPanel(condition="input.viewlength == 'Continuous'", + sliderInput(inputId="period", + label=HTML('Reference years','',as.character(icon("info", class="infoletter")),' Based on this period (target year included) different levels of the selected measure can be calculated. The difference between the result of this calculation and the target year is displayed in the figure. '), min=min(data[CountryCode=="AUT"]$Year), max=max(data[CountryCode=="AUT"]$Year), - value=c(min(data[CountryCode=="AUT"]$Year), - max(data[CountryCode=="AUT"]$Year)-1), + # value=c(min(data[CountryCode=="AUT"]$Year), + # max(data[CountryCode=="AUT"]$Year)-1), + value=c(2010,2019), step=1, sep="", ticks=FALSE + ) + ), + + conditionalPanel(condition="input.viewlength == 'Multi-year'", + selectInput(inputId="multiperiod", + label=HTML('Reference years','',as.character(icon("info", class="infoletter")),' Based on this period (target year included) different levels of the selected measure can be calculated. The difference between the result of this calculation and the target year is displayed in the figure. '), + choices=unique(data[CountryCode=="AUT"]$Year), + selected=c((max(data[CountryCode=="AUT"]$Year)-3):(max(data[CountryCode=="AUT"]$Year)-1)), + multiple=TRUE, + selectize=TRUE + ) ), - selectInput(inputId="area", label=HTML('Reference level','',as.character(icon("info", class="infoletter")),' @@ -378,9 +391,10 @@ tags$p(style="text-align:center;margin-bottom:0px;", choices=unique(data[CountryCode=="AUT"]$Year), selected=max(unique(data[CountryCode=="AUT"]$Year)) ), - +radioButtons(inputId="viewlength2", label="Reference period", choices=c("Continuous", "Multi-year"), selected="Continuous", inline=TRUE), +conditionalPanel(condition="input.viewlength2 == 'Continuous'", sliderInput(inputId="period2", - label=HTML('Additional reference period','',as.character(icon("info", class="infoletter")),' Reference period for the additional country. '), + label=HTML('Additional reference years','',as.character(icon("info", class="infoletter")),' Reference period for the additional country. '), min=min(data[CountryCode=="AUT"]$Year), max=max(data[CountryCode=="AUT"]$Year), value=c(min(data[CountryCode=="AUT"]$Year), @@ -388,7 +402,17 @@ tags$p(style="text-align:center;margin-bottom:0px;", step=1, sep="", ticks=FALSE - ), + ) +), +conditionalPanel(condition="input.viewlength2 == 'Multi-year'", + selectInput(inputId="multiperiod2", + label=HTML('Additional reference years','',as.character(icon("info", class="infoletter")),' Based on this period (target year included) different levels of the selected measure can be calculated. The difference between the result of this calculation and the target year is displayed in the figure. '), + choices=unique(data[CountryCode=="AUT"]$Year), + selected=c((max(data[CountryCode=="AUT"]$Year)-3):(max(data[CountryCode=="AUT"]$Year)-1)), + multiple=TRUE, + selectize=TRUE + ) + ), tags$span(id="infosign", style="padding-top:5px;", icon("paint-brush", class="infoletter paintbrush"), @@ -442,10 +466,10 @@ tags$p(style="text-align:center;margin-bottom:0px;", column(10, #title info fluidRow(align="center", - HTML('

Short-term Mortality Fluctuations

'), + HTML('

Short-term Mortality Fluctuations

'), HTML('The most recent update is: ', paste(lastupdate), '
'), - HTML("The project's website: Human Mortality Database ",as.character(icon("globe", class="contacticon")),"www.mortality.org", as.character(icon("envelope-o", class="contacticon"))," hmd@mortality.org
"), - HTML(" UX/UI and public GitHub repository ", '', as.character(icon("github", class="social")), '', " by László Németh
"), + HTML("The project's website: Human Mortality Database ",as.character(icon("globe", class="contacticon")),"www.mortality.org", as.character(icon("envelope-o", class="contacticon"))," hmd@mortality.org
"), + HTML(" Research article DOI: "," 10.1371/journal.pone.0246663 || ","UX/UI and public GitHub repository ", '', as.character(icon("github", class="social")), '', " by László Németh
"), HTML(" Data for the last available weeks is preliminary and may be incomplete, please refer to the country-specific metadata for details.", '', as.character(icon("file-pdf-o", class="social")),''), HTML('
') ), @@ -669,7 +693,8 @@ server=function(input,output,session){ HTML("The User's Guide provides detailed information on the features such as selection in the figure for summary statistics; clicking for point identification or displaying an additional country or year:"), actionLink(style="margin-right:5px;",inputId="userguide2", label=HTML(as.character(icon("book", class="social")))), HTML(" -

Data for 2020 is preliminary and for the last 1-3 available weeks may be incomplete. Please refer to the Metadata information for country-specific characteristics.

+

The research article provides additional details on the features, the research background and the applied methods: DOI: 10.1371/journal.pone.0246663

+

Data for the last available weeks is preliminary and may be incomplete. Please refer to the Metadata information for country-specific characteristics.

Data and metadata information are freely available for download on the project's website in the Human Mortality Database as well as in the sidebar.

For an optimal user experience using an up-to-date browser, e.g. Chrome or Firefox, is recommended.") @@ -699,15 +724,31 @@ server=function(input,output,session){ updateSliderInput(session,"period", min=min(data[CountryCode==input$country]$Year), max=max(data[CountryCode==input$country]$Year), - value=c(min(data[CountryCode==input$country]$Year), - max(data[CountryCode==input$country]$Year)-1) + value=c(max(2010,min(data[CountryCode==input$country]$Year)), + min(2019,max(data[CountryCode==input$country]$Year)-1)) ) updateSliderInput(session,"period2", min=min(data[CountryCode==input$country2]$Year), max=max(data[CountryCode==input$country2]$Year), - value=c(min(data[CountryCode==input$country2]$Year), - max(data[CountryCode==input$country2]$Year)-1) + value=c(max(2010,min(data[CountryCode==input$country2]$Year)), + min(2019,max(data[CountryCode==input$country2]$Year)-1)) + ) + + +# label="Multiperiod", +# choices=unique(data[CountryCode=="AUT"]$Year), +# selected=c((max(data[CountryCode=="AUT"]$Year)-3):(max(data[CountryCode=="AUT"]$Year)-1)), +# multiple=TRUE, +# selectize=TRUE + updateSelectInput(session,"multiperiod", + choices=unique(data[CountryCode==input$country]$Year), + selected=c(max(2010,min(data[CountryCode==input$country]$Year)):(min(2019,max(data[CountryCode==input$country]$Year)-1))) + ) + + updateSelectInput(session,"multiperiod2", + choices=unique(data[CountryCode==input$country]$Year), + selected=c(max(2010,min(data[CountryCode==input$country]$Year)):(min(2019,max(data[CountryCode==input$country]$Year)-1))) ) }) @@ -823,46 +864,53 @@ server=function(input,output,session){ output$myplot=renderPlot({ req(input$targetyear,input$country,input$period,input$area,input$variable) - + if (input$viewlength == "Continuous") { + myper = c(input$period[1]:input$period[2]) + } else if (input$viewlength == "Multi-year") { + myper = as.numeric(sort(input$multiperiod)) + } myvar=input$variable - + # print(myper) #### The baselines #### #### measures cols=colnames(data)[5:16] #### Weekly averages (across years) - meandata=data[CountryCode %in% input$country & Year %in% c(input$period[1]:input$period[2]), lapply(.SD,mean), .SDcols= cols, by = list(CountryCode,Week,Sex)] + meandata=data[CountryCode %in% input$country & Year %in% c(myper), lapply(.SD,mean), .SDcols= cols, by = list(CountryCode,Week,Sex)] + # print(paste("this is multiperiod", input$multiperiod)) + # multimean=data[CountryCode %in% input$country & Year %in% input$multiperiod, lapply(.SD,mean), .SDcols= cols, by = list(CountryCode,Week,Sex)] + # print(head(multimean)) dataset$meandata=meandata #### Expected level (average of weekly averages) - expectedlevel=data[CountryCode %in% input$country & Year %in% c(input$period[1]:input$period[2]), lapply(.SD,mean), .SDcols= cols, by = list(CountryCode,Sex)] + expectedlevel=data[CountryCode %in% input$country & Year %in% c(myper), lapply(.SD,mean), .SDcols= cols, by = list(CountryCode,Sex)] #### summer #### if (input$country %in% c("AUS2","CHL","NZL_NP")){ - expectedlevelsummer=data[CountryCode %in% input$country & Year %in% c(input$period[1]:input$period[2]) & !(Week %in% 22:38), lapply(.SD,mean), .SDcols= cols, by = list(CountryCode,Sex)] + expectedlevelsummer=data[CountryCode %in% input$country & Year %in% c(myper) & !(Week %in% 22:38), lapply(.SD,mean), .SDcols= cols, by = list(CountryCode,Sex)] } else { #### Expected level without winter season (from December to March included - week 48 -- week 12) - expectedlevelsummer=data[CountryCode %in% input$country & Year %in% c(input$period[1]:input$period[2]) & !(Week %in% c(1:12,48:52)), lapply(.SD,mean), .SDcols= cols, by = list(CountryCode,Sex)] + expectedlevelsummer=data[CountryCode %in% input$country & Year %in% c(myper) & !(Week %in% c(1:12,48:52)), lapply(.SD,mean), .SDcols= cols, by = list(CountryCode,Sex)] } #### lower quartile weekly - q25data=data[CountryCode %in% input$country & Year %in% c(input$period[1]:input$period[2]), lapply(.SD,quantile,prob=0.25), .SDcols= cols, by = list(CountryCode,Week,Sex)] + q25data=data[CountryCode %in% input$country & Year %in% c(myper), lapply(.SD,quantile,prob=0.25), .SDcols= cols, by = list(CountryCode,Week,Sex)] dataset$q25data=q25data #### lower quartile - q25y=data[CountryCode %in% input$country & Year %in% c(input$period[1]:input$period[2]), lapply(.SD, quantile, prob=0.25), .SDcols = cols, by = list(CountryCode,Sex)] + q25y=data[CountryCode %in% input$country & Year %in% c(myper), lapply(.SD, quantile, prob=0.25), .SDcols = cols, by = list(CountryCode,Sex)] #### linear trend expectation - smalldata=data[CountryCode==input$country & Year %in% c(input$period[1]:input$period[2]),c("Year",..myvar,"Week","CountryCode","Sex")] + smalldata=data[CountryCode==input$country & Year %in% c(myper),c("Year",..myvar,"Week","CountryCode","Sex")] linex=rbindlist(by(smalldata,smalldata[,c("Week","Sex","CountryCode")],function(x){ eq=lm(x[[myvar]] ~ Year, data=x) @@ -877,30 +925,36 @@ server=function(input,output,session){ if (input$extracountry == TRUE) { - meandata2=data[CountryCode %in% input$country2 & Year %in% c(input$period2[1]:input$period2[2]), lapply(.SD,mean), .SDcols= cols, by = list(CountryCode,Week,Sex)] + + if (input$viewlength == "Continuous") { + myper2 = c(input$period2[1]:input$period2[2]) + } else if (input$viewlength2 == "Multi-year") { + myper2 = as.numeric(sort(input$multiperiod2)) + } + meandata2=data[CountryCode %in% input$country2 & Year %in% myper2, lapply(.SD,mean), .SDcols= cols, by = list(CountryCode,Week,Sex)] dataset$meandata2=meandata2 #### Expected level (average of weekly averages) - expectedlevel2=data[CountryCode %in% input$country2 & Year %in% c(input$period2[1]:input$period2[2]), lapply(.SD,mean), .SDcols= cols, by = list(CountryCode,Sex)] + expectedlevel2=data[CountryCode %in% input$country2 & Year %in% myper2, lapply(.SD,mean), .SDcols= cols, by = list(CountryCode,Sex)] if (input$country2 %in% c("AUS2","CHL","NZL_NP")){ - expectedlevelsummer2=data[CountryCode %in% input$country2 & Year %in% c(input$period2[1]:input$period2[2]) & !(Week %in% 22:38), lapply(.SD,mean), .SDcols= cols, by = list(CountryCode,Sex)] + expectedlevelsummer2=data[CountryCode %in% input$country2 & Year %in% myper2 & !(Week %in% 22:38), lapply(.SD,mean), .SDcols= cols, by = list(CountryCode,Sex)] } else { #### Expected level without winter season (from December to March included - week 48 -- week 12) - expectedlevelsummer2=data[CountryCode %in% input$country2 & Year %in% c(input$period2[1]:input$period2[2]) & !(Week %in% c(1:12,48:52)), lapply(.SD,mean), .SDcols= cols, by = list(CountryCode,Sex)] + expectedlevelsummer2=data[CountryCode %in% input$country2 & Year %in% myper2 & !(Week %in% c(1:12,48:52)), lapply(.SD,mean), .SDcols= cols, by = list(CountryCode,Sex)] } #### lower quartile - q25data2=data[CountryCode %in% input$country2 & Year %in% c(input$period2[1]:input$period2[2]), lapply(.SD,quantile,prob=0.25), .SDcols= cols, by = list(CountryCode,Week,Sex)] + q25data2=data[CountryCode %in% input$country2 & Year %in% myper2, lapply(.SD,quantile,prob=0.25), .SDcols= cols, by = list(CountryCode,Week,Sex)] dataset$q25data2=q25data2 #### lower quartile - q25y2=data[CountryCode %in% input$country2 & Year %in% c(input$period2[1]:input$period2[2]), lapply(.SD, quantile, prob=0.25), .SDcols = cols, by = list(CountryCode,Sex)] + q25y2=data[CountryCode %in% input$country2 & Year %in% myper2, lapply(.SD, quantile, prob=0.25), .SDcols = cols, by = list(CountryCode,Sex)] - smalldata2=data[CountryCode == input$country2 & Year %in% c(input$period2[1]:input$period2[2]),c("Year",..myvar,"Week","CountryCode","Sex")] + smalldata2=data[CountryCode == input$country2 & Year %in% myper2,c("Year",..myvar,"Week","CountryCode","Sex")] linex2=rbindlist(by(smalldata2,smalldata2[,c("Week","Sex","CountryCode")],function(x){ eq=lm(x[[myvar]] ~ Year, data=x) res=predict.lm(eq,data.frame(Year=as.numeric(input$targetyear2))) @@ -975,10 +1029,10 @@ server=function(input,output,session){ Qb=as.numeric(q25y[CountryCode %in% input$country & Sex == "b", ..myvar]) q25allsel=rbind( - data[CountryCode %in% input$country & Year %in% c(input$period[1]:input$period[2]) & Sex == "m",c("CountryCode", "Year","Week","Sex",..myvar)][which(data[CountryCode %in% input$country & Year %in% c(input$period[1]:input$period[2]) & Sex == "m",..myvar]