Permalink
Cannot retrieve contributors at this time
Name already in use
A tag already exists with the provided branch name. Many Git commands accept both tag and branch names, so creating this branch may cause unexpected behavior. Are you sure you want to create this branch?
stmortality/app.R
Go to fileThis commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
1872 lines (1360 sloc)
90.2 KB
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| #global.R | |
| library(data.table) | |
| library(shiny) | |
| library(ggplot2) | |
| ### fetch url | |
| data=data.table(read.table("https://mortality.org/File/GetDocument/Public/STMF/Outputs/stmf.csv", sep=",", header=T)) | |
| x=as.character(unlist(read.table("https://mortality.org/File/GetDocument/Public/STMF/Outputs/stmf.csv",header=F,nrows = 1, sep=",", comment.char = ""))) | |
| ### date of the last update | |
| y=regexpr("Last modified:", x) | |
| z=attributes(y)$match.length | |
| lastupdate=substr(x,y+z+1,y+z+10) | |
| # country names | |
| countrylistnames = c( | |
| "Australia" = "AUS", | |
| "Austria" = "AUT", | |
| "Belgium" = "BEL", | |
| "Bulgaria" = "BGR", | |
| "Canada" = "CAN", | |
| "Chile" = "CHL", | |
| "Croatia" = "HRV", | |
| "Czech Republic" = "CZE", | |
| "Denmark" = "DNK", | |
| "England and Wales" = "GBRTENW", | |
| "Estonia" = "EST", | |
| "Finland" = "FIN", | |
| "France" = "FRATNP", | |
| "Germany" = "DEUTNP", | |
| "Greece" = "GRC", | |
| "Hungary" = "HUN", | |
| "Iceland" = "ISL", | |
| "Israel" = "ISR", | |
| "Italy" = "ITA", | |
| "Latvia" = "LVA", | |
| "Lithuania" = "LTU", | |
| "Luxembourg" = "LUX", | |
| "Netherlands" = "NLD", | |
| "New Zealand" = "NZL_NP", | |
| "Northern Ireland" = "GBR_NIR", | |
| "Norway" = "NOR", | |
| "Poland" = "POL", | |
| "Portugal" = "PRT", | |
| "Republic of Korea" = "KOR", | |
| "Russia" = "RUS", | |
| "Scotland" = "GBR_SCO", | |
| "Slovakia" = "SVK", | |
| "Slovenia" = "SVN", | |
| "Spain" = "ESP", | |
| "Sweden" = "SWE", | |
| "Switzerland" = "CHE", | |
| "Taiwan" = "TWN", | |
| "United States of America" = "USA", | |
| "Australia DCD" = "AUS2") | |
| cv=countrylistnames[match(unique(data$CountryCode), countrylistnames)] | |
| countrylist=cv[order(names(cv))] | |
| ### ui.R | |
| ui=fluidPage( | |
| #add meta | |
| tags$head( | |
| tags$meta(property="site_name", content="Short-term Mortality Fluctuations"), | |
| tags$meta(property="title", content="Human Mortality Database Short-term Mortality Fluctuations weekly excess mortality visualization"), | |
| tags$meta(property="description", content="An open-sourced, web-based application to analyze weekly excess mortality based on the Short-term Mortality Fluctuations data series"), | |
| tags$meta(property="image", content="HMD_logo.png"), | |
| tags$meta(property="url", content="https://mpidr.shinyapps.io/stmortality"), | |
| tags$meta(property="type", content="website"), | |
| tags$link(rel="shortcut icon", type="image/jpg", href="HMD_logo.png"), | |
| tags$title("Short-term Mortality Fluctuations - Human Mortality Database") | |
| ), | |
| # add font | |
| tags$link(rel="stylesheet", href="https://fonts.googleapis.com/css2?family=Muli&family=Manrope&family=Exo&family=Quicksand&display=swap"), | |
| tags$style(type="text/css", "body {padding-top: 20px;font-family: 'Muli', sans-serif;}"), | |
| # add inline CSS | |
| tags$style( | |
| HTML( | |
| " | |
| i { | |
| color: #66A0C4; | |
| } | |
| i.contacticon { | |
| color: black; | |
| } | |
| i.exclamation { | |
| color: #ef7f1a; | |
| } | |
| #exclamation { | |
| display: inline-block; | |
| border-bottom: 1px dashed #66A0C4; | |
| padding: 0px 5px 0px 5px; | |
| margin-left: 5px; | |
| } | |
| #exclamation .tooltiptext { | |
| visibility: hidden; | |
| min-width: 300px; | |
| background-color: #66A0C4; | |
| color: #fff; | |
| text-align:justify; | |
| text-justify:left; | |
| border-radius: 6px; | |
| margin-left: 5px; | |
| padding: 15px 15px 15px 15px; | |
| box-shadow: 0 4px 8px 0 rgba(0, 0, 0, 0.2), 0 6px 20px 0 rgba(0, 0, 0, 0.19); | |
| font-weight: bold; | |
| /* Position the tooltip */ | |
| position: absolute; | |
| z-index: 100; | |
| } | |
| #exclamation .tooltiptext.referencelevel{ | |
| margin-top: -300px; | |
| } | |
| #exclamation .tooltiptext.clickpointhelp{ | |
| margin-left: -500px; | |
| } | |
| #exclamation:hover .tooltiptext { | |
| visibility: visible; | |
| } | |
| i.infoletter { | |
| color: #66A0C4; | |
| } | |
| i.infoletter:hover { | |
| border-color:black; | |
| color: #ef7f1a; | |
| text-shadow: 2px 2px 5px black; | |
| } | |
| #infosign{ | |
| display: inline-block; | |
| border-bottom: 1px dashed #66A0C4; | |
| padding: 0px 5px 0px 5px; | |
| margin-left: 5px; | |
| } | |
| #infosign .tooltiptext { | |
| visibility: hidden; | |
| min-width: 300px; | |
| background-color: #66A0C4; | |
| color: #fff; | |
| text-align:justify; | |
| text-justify:left; | |
| border-radius: 6px; | |
| margin-left: 5px; | |
| padding: 15px 15px 15px 15px; | |
| box-shadow: 0 4px 8px 0 rgba(0, 0, 0, 0.2), 0 6px 20px 0 rgba(0, 0, 0, 0.19); | |
| font-weight: bold; | |
| /* Position the tooltip */ | |
| position: absolute; | |
| z-index: 100; | |
| } | |
| #infosign .tooltiptext.referencelevel{ | |
| margin-top: -300px; | |
| } | |
| #infosign .tooltiptext.clickpointhelp{ | |
| margin-left: -500px; | |
| } | |
| #infosign:hover .tooltiptext { | |
| visibility: visible; | |
| } | |
| #variable { | |
| display: inline; | |
| margin: 0px; | |
| } | |
| i.social { | |
| color: #66A0C4; | |
| } | |
| i.social:hover { | |
| color: #ef7f1a; | |
| transform: scale(1.5); | |
| } | |
| i.paintbrush:hover { | |
| color: #ef7f1a; | |
| transform: scale(1.5); | |
| } | |
| .control-label { | |
| display: inline-flex; | |
| } | |
| .irs-bar { | |
| border-top: 1px solid #66A0C4; | |
| border-bottom: 1px solid #66A0C4; | |
| background: #66A0C4; | |
| } | |
| .irs-from, .irs-to { | |
| background: #66A0C4; | |
| } | |
| a:link { | |
| color: #66A0C4; | |
| font-weight:bold; | |
| background-color: transparent; | |
| text-decoration: none; | |
| } | |
| a:hover { | |
| color: #ef7f1a; | |
| background-color: transparent; | |
| text-decoration: underline; | |
| } | |
| a.logo:hover { | |
| text-decoration: none; | |
| } | |
| a.iconlink:hover{ | |
| text-decoration: none; | |
| transform: scale(1.5); | |
| } | |
| .sidebar{ | |
| border-right: 1px solid #66A0C4; | |
| border-radius:1px; | |
| } | |
| .col-sm-9{ | |
| padding: 0px 3px 0px 3px; | |
| } | |
| .tutorialvid{ | |
| display: block; | |
| margin-left: auto; | |
| margin-right: auto; | |
| width: 80%; | |
| min-height=300px; | |
| } | |
| #shiny-notification-welcome { | |
| position:fixed; | |
| top: calc(25%); | |
| left: calc(25%); | |
| box-shadow: 0 4px 8px 0 rgba(0, 0, 0, 0.2), 0 6px 20px 0 rgba(0, 0, 0, 0.19); | |
| color: black; | |
| max-width: 50%; | |
| opacity: 0.9; | |
| } | |
| #shiny-notification-userguide { | |
| position:fixed; | |
| top: calc(2%); | |
| left: calc(16.66%); | |
| box-shadow: 0 4px 8px 0 rgba(0, 0, 0, 0.2), 0 6px 20px 0 rgba(0, 0, 0, 0.19); | |
| color: black; | |
| max-width: 80vw; | |
| opacity: 1; | |
| } | |
| .checkbox-inline { | |
| margin-left: 0px; | |
| margin-right: 10px; | |
| } | |
| .checkbox-inline+.checkbox-inline { | |
| margin-left: 0px; | |
| margin-right: 10px; | |
| } | |
| " | |
| ) | |
| ), | |
| fluidRow( | |
| # sidebar | |
| column(2, class="sidebar", | |
| # logo | |
| fluidRow(HTML('<center><a class="logo" href="https://www.mortality.org/" target="_blank"><img class="logo" src="HMD.svg" style="max-width:25%;"></a></center>')), | |
| fluidRow(HTML('<center><h5 style="color: #2a4770;text-align:center;font-weight:bold;padding: 0px 5px 0px 5px">Human Mortality Database</h5></center>')), | |
| # social links | |
| tags$p(style="text-align:center;margin-bottom:0px;", | |
| HTML('<b>HMD Twitter:</b> <a class=iconlink href="https://twitter.com/HMDatabase" target="_blank" style="margin-right:5px;">',as.character(icon("twitter", class="social")),'</a>'), | |
| HTML("<b>User's Guide:</b>"),actionLink(style="margin-right:5px;",inputId="userguide", label=HTML(as.character(icon("book", class="social"))))), | |
| hr(style="background-color: #66A0C4;height: 3px;border-radius: 2px;margin-top:5px;margin-bottom:2px;"), | |
| # input selectors | |
| fluidRow(align="center",selectInput(inputId="country", | |
| label=HTML('Country or region'), | |
| choices=countrylist, | |
| selected="AUT" | |
| ), | |
| selectInput(inputId="targetyear", | |
| label=HTML('<span style="color:black;">Target year</span>','<span id="infosign">',as.character(icon("info", class="infoletter")),'<center><span class="tooltiptext"> The target year is compared to the selected reference period. </span></center> </span>'), | |
| choices=unique(data[CountryCode=="AUT"]$Year), | |
| selected=max(unique(data[CountryCode=="AUT"]$Year)) | |
| ), | |
| checkboxInput(inputId="alldata", label="Show other years", value = FALSE)), | |
| fluidRow(align="center",selectInput(inputId="variable", | |
| label=HTML('Measure','<span id="exclamation">',as.character(icon("exclamation", class="exclamation")),'<span class="tooltiptext"> Death rates are displayed on a scale of 100000 person-years.</span> </span>'), | |
| choices=c("Deaths, Total" = "DTotal", | |
| "Death Rate, Total" = "RTotal", | |
| "Deaths, Ages 0-14" = "D0_14", | |
| "Deaths, Ages 15-64" = "D15_64", | |
| "Deaths, Ages 65-74" = "D65_74", | |
| "Deaths, Ages 75-84" = "D75_84", | |
| "Deaths, Ages 85+" = "D85p", | |
| "Age-specific Death Rate, Ages 0-14" = "R0_14", | |
| "Age-specific Death Rate, Ages 15-64" = "R15_64", | |
| "Age-specific Death Rate, Ages 65-74" = "R65_74", | |
| "Age-specific Death Rate, Ages 75-84" = "R75_84", | |
| "Age-specific Death Rate, Ages 85+" = "R85p") | |
| ), | |
| checkboxGroupInput(inputId="sexchoice", | |
| label="Sex", | |
| choiceNames = list("Total","Female","Male"), choiceValues = list("b","f","m"), | |
| inline = TRUE, | |
| selected=c("b","f","m") | |
| ), | |
| radioButtons(inputId="viewlength", label="Reference period", choices=c("Continuous", "Multi-year"), selected="Continuous", inline=TRUE), | |
| conditionalPanel(condition="input.viewlength == 'Continuous'", | |
| sliderInput(inputId="period", | |
| label=HTML('Reference years','<span id="infosign">',as.character(icon("info", class="infoletter")),'<span class="tooltiptext"> 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. </span> </span>'), | |
| 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(2010,2019), | |
| step=1, | |
| sep="", | |
| ticks=FALSE | |
| ) | |
| ), | |
| conditionalPanel(condition="input.viewlength == 'Multi-year'", | |
| selectInput(inputId="multiperiod", | |
| label=HTML('Reference years','<span id="infosign">',as.character(icon("info", class="infoletter")),'<span class="tooltiptext"> 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. </span> </span>'), | |
| 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','<span id="infosign">',as.character(icon("info", class="infoletter")),'<span class="tooltiptext referencelevel"> | |
| <center><u>Week-specific Averages</u></center> | |
| <span> The reference level for a given week equals to the arithmetic mean of the available data for that week in the years of the selected period.</span> | |
| <center><u>Week-specific Trends</u></center> | |
| <span>Expected value of a linear trend fitted over years in the selected period. </span> | |
| <center><u>Week-specific Lower Quartiles</u></center> | |
| <span>The reference level for a given week equals to the lower quartile of the available data for that week in the years of the selected period.</span> | |
| <center><u>Yearly-average-week</u></center> | |
| <span>The arithmetic mean of the week-specific averages over the period.</span> | |
| <center><u>Summer-average-week</u></center> | |
| <span>The arithmetic mean of the week-specific averages over the period excluding calendar weeks between 48 and 12.</span> | |
| <center><u>Yearly Lower-quartile-week</u></center> | |
| <span>The arithmetic mean of values below the lower quartile based on all values in the selected reference period.</span> | |
| </span> </span>'), | |
| choices=c("Week-specific Averages", | |
| "Week-specific Trends", | |
| "Week-specific Lower Quartiles", | |
| "Yearly Average-week", | |
| "Summer Average-week", | |
| "Yearly Lower-quartile-week" | |
| ), | |
| selected="Week-specific Trends" | |
| ), | |
| tags$span(id="infosign", style="padding-top:5px;", | |
| icon("paint-brush", class="infoletter paintbrush"), | |
| tags$span(class="tooltiptext", | |
| "Change the color in the figure with the boxes.")), | |
| actionLink(style="margin-right:5px;",inputId="colorboxhmd", label=HTML('<img src="colorboxhmd.png" style="width:1.5em;">')), | |
| actionLink(style="margin-right:5px;",inputId="colorboxred", label=HTML('<img src="colorboxred.png" style="width:1.5em;">')), | |
| actionLink(style="margin-right:5px;",inputId="colorboxgreen", label=HTML('<img src="colorboxgreen.png" style="width:1.5em;">')), | |
| actionLink(style="margin-right:5px;",inputId="colorboxblue", label=HTML('<img src="colorboxblue.png" style="width:1.5em;">')), | |
| actionLink(style="margin-right:5px;",inputId="colorboxearth", label=HTML('<img src="colorboxearth.png" style="width:1.5em;">')) | |
| ), | |
| hr(style="background-color: #66A0C4;height: 3px;border-radius: 2px;margin-top:5px;margin-bottom:2px;"), | |
| fluidRow(align="center",checkboxInput(inputId="extracountry", label="Additional country or region", value = FALSE)), | |
| conditionalPanel(condition="input.extracountry == true", | |
| fluidRow(align="center",selectInput(inputId="country2", | |
| label=HTML('Choose an additional country'), | |
| choices=countrylist, | |
| selected="AUT" | |
| ), | |
| selectInput(inputId="targetyear2", | |
| label=HTML('<span style="color:black;">Additional target year</span>','<span id="infosign">',as.character(icon("info", class="infoletter")),'<center><span class="tooltiptext"> The target year is compared to the selected reference period. </span></center> </span>'), | |
| 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 years','<span id="infosign">',as.character(icon("info", class="infoletter")),'<span class="tooltiptext"> Reference period for the additional country. </span> </span>'), | |
| 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), | |
| step=1, | |
| sep="", | |
| ticks=FALSE | |
| ) | |
| ), | |
| conditionalPanel(condition="input.viewlength2 == 'Multi-year'", | |
| selectInput(inputId="multiperiod2", | |
| label=HTML('Additional reference years','<span id="infosign">',as.character(icon("info", class="infoletter")),'<span class="tooltiptext"> 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. </span> </span>'), | |
| 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"), | |
| tags$span(class="tooltiptext", | |
| "Change the color in the figure with the boxes.")), | |
| actionLink(style="margin-right:5px;",inputId="colorboxhmd2", label=HTML('<img src="colorboxhmd.png" style="width:1.5em;">')), | |
| actionLink(style="margin-right:5px;",inputId="colorboxred2", label=HTML('<img src="colorboxred.png" style="width:1.5em;">')), | |
| actionLink(style="margin-right:5px;",inputId="colorboxgreen2", label=HTML('<img src="colorboxgreen.png" style="width:1.5em;">')), | |
| actionLink(style="margin-right:5px;",inputId="colorboxblue2", label=HTML('<img src="colorboxblue.png" style="width:1.5em;">')), | |
| actionLink(style="margin-right:5px;",inputId="colorboxearth2", label=HTML('<img src="colorboxearth.png" style="width:1.5em;">')) | |
| ) | |
| ), | |
| hr(style="background-color: #66A0C4;height: 3px;border-radius: 2px;margin-top:5px;margin-bottom:2px;"), | |
| # data links | |
| HTML('<p style="text-align:center;"><span><b>Data:</b></span><br/> <a class=iconlink href="https://mortality.org/File/GetDocument/Public/STMF/Outputs/stmf.xlsx" style="margin-right:5px;">',"XLSX", | |
| '</a> <a class=iconlink href="https://mortality.org/File/GetDocument/Public/STMF/Outputs/stmf.csv" style="margin-right:5px;">', "CSV",'</a> | |
| </a> <a class=iconlink href="https://mortality.org/File/GetDocument/Public/STMF_DOC/STMFNote.pdf" style="margin-right:5px;">', "Note",'</a> | |
| </a> <a class=iconlink href="https://mortality.org/File/GetDocument/Public/STMF_DOC/STMFmetadata.pdf" style="margin-right:5px;">', "Meta",'</a> | |
| </p>'), | |
| hr(style="background-color: #66A0C4;height: 3px;border-radius: 2px;margin-top:5px;margin-bottom:5px;"), | |
| #logos | |
| fluidRow(align = "center", | |
| a(href="https://www.demogr.mpg.de/en",img(src="MPIDR-EN.svg", style="width:45%;", class="logo"), target="_blank", class="logo"), | |
| a(href="https://www.site.demog.berkeley.edu/",img(src="UCB.svg", style="width:45%;", class="logo"),target="_blank", class="logo") | |
| ) | |
| ), | |
| #main | |
| column(10, | |
| #title info | |
| fluidRow(align="center", | |
| HTML('<h2 style="margin-top:0px;margin-bottom:0px;color: #2a4770;text-align:center;font-weight:bold;"> Short-term Mortality Fluctuations </h2>'), | |
| HTML('<span>The most recent update is: ', paste(lastupdate), '</span><br/>'), | |
| HTML("<span>The project's website: Human Mortality Database ",as.character(icon("globe", class="contacticon")),"<a href='https://www.mortality.org/' target='_blank'>www.mortality.org</a>", as.character(icon("envelope-o", class="contacticon"))," <a href='mailto:hmd@mortality.org'> hmd@mortality.org</a></span><br/>"), | |
| HTML('<span>This online data repository was supported by the Volkswagen Foundation (Volkswagen Stiftung) in the framework of the supported project on "Strengthening a reliable evidence base for monitoring the COVID-19 and other disasters"</span><br/>'), | |
| HTML("<span style='color:black;font-weight:bold;'> Data descriptor article DOI: ",as.character(icon("database", class="contacticon")),"<a class=iconlink href='https://doi.org/10.1038/s41597-021-01019-1' target='_blank'> 10.1038/s41597-021-01019-1 </a>","</span><br/>"), | |
| HTML("<span style='color:green;font-weight:bold;'> Research article DOI: ","<a class=iconlink href='https://doi.org/10.1371/journal.pone.0246663' target='_blank'> 10.1371/journal.pone.0246663 </a> || ","UX/UI and public GitHub repository ", '<a class=iconlink href="https://github.molgen.mpg.de/nemeth/stmortality" target="_blank">', as.character(icon("github", class="social")), '</a>', " by <a href='https://www.demogr.mpg.de/en/about_us_6113/staff_directory_1899/laszlo_nemeth_2635' target='_blank'> László Németh</a></span><br/>"), | |
| HTML("<span style='color:red;font-weight:bold;'> Data for the last available weeks is preliminary and may be incomplete, please refer to the country-specific metadata for details.", '<a class=iconlink href="https://mortality.org/File/GetDocument/Public/STMF_DOC/STMFmetadata.pdf" style="margin-right:5px;">', as.character(icon("file-pdf-o", class="social")),'</a></span>'), | |
| HTML('<hr style="width=60%;background-color:#66A0C4;height:1px;border-radius:2px;margin: 0px 15px 5px 15px;">') | |
| ), | |
| # figure 1 | |
| div( | |
| style = "position:relative;padding: 5px 10px 5px 0px;", | |
| plotOutput("myplot", height = "400px", | |
| click = "plot_click", | |
| brush = brushOpts( | |
| id = "plot1_brush" | |
| ), | |
| hover = hoverOpts("plot_hover", delay = 100, delayType = "debounce") | |
| ), | |
| uiOutput("hover_info") | |
| ), | |
| # figure 2 | |
| conditionalPanel( | |
| condition="input.extracountry == true", | |
| div( | |
| HTML('<hr style="width=60%;background-color:#66A0C4;height:1px;border-radius:2px;margin: 0px 15px 5px 15px;">'), | |
| style = "position:relative;padding: 5px 10px 5px 0px;", | |
| plotOutput("extracountryfigure",height = "400px", | |
| click = "plot_click2", | |
| brush = brushOpts(id = "plot2_brush"), | |
| hover = hoverOpts("plot_hover2", delay = 100, delayType = "debounce") | |
| ), | |
| uiOutput("hover_info2")) | |
| ), | |
| hr(style="background-color: #66A0C4;height: 3px;border-radius: 2px;margin-top:10px;margin-bottom:5px;"), | |
| # statistics | |
| fluidRow(column(6, | |
| HTML('Summary statistics','<span id="infosign">',as.character(icon("info", class="infoletter")),'<span class="tooltiptext"> | |
| <center>Select an area in the graph to show the summary statistics.</center></span> </span>'), | |
| uiOutput("brushedweeks"), | |
| tableOutput("brush_info"), | |
| uiOutput("brushedweeks2"), | |
| tableOutput("brush_info2") | |
| ), | |
| column(6, | |
| HTML('Clicked point information','<span id="infosign">',as.character(icon("info", class="infoletter")),'<span class="tooltiptext clickpointhelp"> | |
| <center>Click in the graph to identify data points from other years.<br/>(Note: "Show other years" should be checked.)</center></span> </span>'), | |
| uiOutput("click_info"), | |
| uiOutput("click_info2") | |
| ) | |
| ) | |
| ) | |
| ) | |
| ) | |
| #server.R | |
| server=function(input,output,session){ | |
| # user's guide | |
| observeEvent(input$userguide,{ | |
| showNotification(id="userguide",duration=NA, type="message", | |
| ui=fluidRow(style="max-height: 80vh;overflow:auto;padding-left:15px;", | |
| HTML( | |
| "<div style='overflow-y: auto;'> | |
| <h2 style='margin-top:0px;'> User's Guide </h2> | |
| <div> | |
| <span>Based on the Short-term Mortality Fluctuations data series, this tool displays the excess mortality in weekly death counts or death rates in a year compared to a reference level.</span></div> | |
| <div style='padding-top:15px;padding-bottom:15px;'><center><img src='surface1.png' style='max-width:95%;box-shadow: 0 4px 8px 0 rgba(0, 0, 0, 0.2), 0 6px 20px 0 rgba(0, 0, 0, 0.19);' onclick='window.open(this.src)'></center></div> | |
| <div> | |
| <span> The sidebar on the left (green area) contains the input controls where the country or region, years, additional country or region, etc. can be selected. </span> | |
| <span> Based on the input the figure in the orange area is updated. In the blue area summary statistics appear on brushing an area or clicking a point in the figure.</span> | |
| </div> | |
| <div style='display:inline-block;padding-top:15px;'> <h6><b> Selecting an area for summary statistics</b></h6> </div> | |
| <div style='padding-top:15px;padding-bottom:15px;'><center><img src='surface2.png' style='max-width:95%;box-shadow: 0 4px 8px 0 rgba(0, 0, 0, 0.2), 0 6px 20px 0 rgba(0, 0, 0, 0.19);' onclick='window.open(this.src)'></center></div> | |
| <div> | |
| <span> Select an area with the cursor in the figure to display summary statistics between the weeks corresponding to the selection. </span> | |
| <span> After selections summary statistics appear below the figure with the information on the selected measure. </span> | |
| <span> In this example, the selection is in England and Wales between weeks 8 and 20. Please note that this selection does not select the weeks of a continous excess mortality polygon (Hint: hover information).</span> | |
| </div> | |
| <div style='display:inline-block;'> <h6><b> Year-week identification </b></h6> </div> | |
| <div style='padding-top:15px;padding-bottom:15px;'><center><img src='surface3.png' style='max-width:95%;box-shadow: 0 4px 8px 0 rgba(0, 0, 0, 0.2), 0 6px 20px 0 rgba(0, 0, 0, 0.19);' onclick='window.open(this.src)'></center></div> | |
| <div> | |
| <span> If the 'Show other years' option is selected in the sidebar clicking with the cursor in the figure identifies the closest point. </span> | |
| <span> This example shows a click in the figure for French Females and the data point is identified to be in year 2003, week 33 corresponding to the heatwave in France in that year.</span> | |
| </div> | |
| <div style='display:inline-block;padding-top:15px;'> <h6><b> Excess mortality polygon information </b></h6> </div> | |
| <div style='padding-top:15px;padding-bottom:15px;'><center><img src='surface4.png' style='max-width:95%;box-shadow: 0 4px 8px 0 rgba(0, 0, 0, 0.2), 0 6px 20px 0 rgba(0, 0, 0, 0.19);' onclick='window.open(this.src)'></center></div> | |
| <div> | |
| <span> Hovering with the cursor over an excess mortality polygon gives information on its length. </span> | |
| <span> This example shows a 25-week-long excess mortality for Males.</span> | |
| </div> | |
| <div style='display:inline-block;padding-top:15px;'> <h6><b> Additional country or region</b></h6> | |
| <span> An additional country or region can be added by selecting the checkbox in the sidebar for easier comparison. </span> | |
| </div> | |
| </div> | |
| <div style='display:inline-block;padding-top:15px;'> <h6><b> Color themes</b></h6> | |
| <span> Different colors can be selected with the colored icons in the sidebar. </span> | |
| </div> | |
| </div> | |
| </div> | |
| ") | |
| ) | |
| ) | |
| }) | |
| observeEvent(input$userguide2,{ | |
| showNotification(id="userguide",duration=NA,type="message", | |
| ui=fluidRow(style="max-height: 80vh;overflow:auto;padding-left:15px;", | |
| HTML( | |
| "<div style='overflow-y: auto;'> | |
| <h2 style='margin-top:0px;'> User's Guide </h2> | |
| <div> | |
| <span>Based on the Short-term Mortality Fluctuations data series, this tool displays the excess mortality in weekly death counts or death rates in a year compared to a reference level.</span></div> | |
| <div style='padding-top:15px;padding-bottom:15px;'><center><img src='surface1.png' style='max-width:95%;box-shadow: 0 4px 8px 0 rgba(0, 0, 0, 0.2), 0 6px 20px 0 rgba(0, 0, 0, 0.19);' onclick='window.open(this.src)'></center></div> | |
| <div> | |
| <span> The sidebar on the left (green area) contains the input controls where the country, years, additional country, etc. can be selected. </span> | |
| <span> Based on the input the figure in the orange area is updated. In the blue area summary statistics appear on brushing an area or clicking a point in the figure.</span> | |
| </div> | |
| <div style='display:inline-block;padding-top:15px;'> <h6><b> Selecting an area for summary statistics</b></h6> </div> | |
| <div style='padding-top:15px;padding-bottom:15px;'><center><img src='surface2.png' style='max-width:95%;box-shadow: 0 4px 8px 0 rgba(0, 0, 0, 0.2), 0 6px 20px 0 rgba(0, 0, 0, 0.19);' onclick='window.open(this.src)'></center></div> | |
| <div> | |
| <span> Select an area with the cursor in the figure to display summary statistics between the weeks corresponding to the selection. </span> | |
| <span> After selections summary statistics appear below the figure with the information on the selected measure. </span> | |
| <span> In this example, the selection is in England and Wales between weeks 8 and 20. Please note that this selection does not select the weeks of a continous excess mortality polygon (Hint: hover information).</span> | |
| </div> | |
| <div style='display:inline-block;'> <h6><b> Year-week identification </b></h6> </div> | |
| <div style='padding-top:15px;padding-bottom:15px;'><center><img src='surface3.png' style='max-width:95%;box-shadow: 0 4px 8px 0 rgba(0, 0, 0, 0.2), 0 6px 20px 0 rgba(0, 0, 0, 0.19);' onclick='window.open(this.src)'></center></div> | |
| <div> | |
| <span> If the 'Show other years' option is selected in the sidebar clicking with the cursor in the figure identifies the closest point. </span> | |
| <span> This example shows a click in the figure for French Females and the data point is identified to be in year 2003, week 33 corresponding to the heatwave in France in that year.</span> | |
| </div> | |
| <div style='display:inline-block;padding-top:15px;'> <h6><b> Excess mortality polygon information </b></h6> </div> | |
| <div style='padding-top:15px;padding-bottom:15px;'><center><img src='surface4.png' style='max-width:95%;box-shadow: 0 4px 8px 0 rgba(0, 0, 0, 0.2), 0 6px 20px 0 rgba(0, 0, 0, 0.19);' onclick='window.open(this.src)'></center></div> | |
| <div> | |
| <span> Hovering with the cursor over an excess mortality polygon gives information on its length. </span> | |
| <span> This example shows a 25-week-long excess mortality for Males.</span> | |
| </div> | |
| <div style='display:inline-block;padding-top:15px;'> <h6><b> Additional country </b></h6> | |
| <span> An additional country can be added by selecting the checkbox in the sidebar for easier comparison. </span> | |
| </div> | |
| </div> | |
| <div style='display:inline-block;padding-top:15px;'> <h6><b> Color themes</b></h6> | |
| <span> Different colors can be selected with the colored icons in the sidebar. </span> | |
| </div> | |
| </div> | |
| </div> | |
| ") | |
| ) | |
| ) | |
| }) | |
| #welcome message | |
| observe({ | |
| showNotification(id="welcome", | |
| HTML(' | |
| <h2> Human Mortality Database </h2> | |
| <h3> Short-term Mortality Fluctuations </h3> | |
| <p> Welcome to the visualisation of the Short-term Mortality Fluctuations data series. | |
| This tool displays the excess mortality or mortality deficit in weekly death counts or death rates in a year compared to a reference level. </p>'), | |
| tags$p( | |
| HTML("<b>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:</b>"), | |
| actionLink(style="margin-right:5px;",inputId="userguide2", label=HTML(as.character(icon("book", class="social")))), | |
| #tags$div(class="tutorialvid",tags$iframe(width="100%", height="292", src="sample.mp4", frameborder="0", allow="picture-in-picture", allowfullscreen=TRUE)), | |
| HTML(" | |
| <p><span style='color:green;font-weight:bold;'> Comprehensive description of the data collected can be found in DOI: <a class=iconlink href='https://doi.org/10.1038/s41597-021-01019-1' target='_blank'> 10.1038/s41597-021-01019-1 </a></span></p> | |
| <p><span style='color:green;font-weight:bold;'> The research article provides additional details on the features, the research background and the applied methods: DOI: <a class=iconlink href='https://doi.org/10.1371/journal.pone.0246663' target='_blank'> 10.1371/journal.pone.0246663 </a></span></p> | |
| <p><span style='color:red;font-weight:bold;'> Data for the last available weeks is preliminary and may be incomplete.</span> Please refer to the Metadata information for country-specific characteristics.</p> | |
| <p> Data and metadata information are freely available for download on the project's website in the <a href='https://www.mortality.org/' target='_blank'>Human Mortality Database</a> as well as in the sidebar.</p> | |
| <span>For an optimal user experience using an up-to-date browser, e.g. Chrome or Firefox, is recommended.</span>") | |
| ), | |
| duration = 60, type="message") | |
| }) | |
| #update input selectors | |
| observe({ | |
| updateSelectInput(session,"targetyear", | |
| choices=unique(data[CountryCode==input$country]$Year), | |
| selected=max(unique(data[CountryCode==input$country]$Year)) | |
| ) | |
| updateSelectInput(session,"targetyear2", | |
| choices=unique(data[CountryCode==input$country2]$Year), | |
| selected=max(unique(data[CountryCode==input$country2]$Year)) | |
| ) | |
| updateSliderInput(session,"period", | |
| min=min(data[CountryCode==input$country]$Year), | |
| max=max(data[CountryCode==input$country]$Year), | |
| 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(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))) | |
| ) | |
| }) | |
| dataset = reactiveValues() | |
| #### theme #### | |
| dataset$fill = c("Mortality deficit" = "lightblue1","Excess mortality" = "darkorange2") | |
| dataset$color = c("All available years" = "gray80", | |
| "Reference level" = "#66A0C4", | |
| "Target year" = "black") | |
| # , | |
| # "Additional country" = "tan2") | |
| observeEvent(input$colorboxhmd,{ | |
| dataset$fill = c("Mortality deficit" = "lightblue1","Excess mortality" = "darkorange2") | |
| dataset$color = c("All available years" = "gray80", | |
| "Reference level" = "#66A0C4", | |
| "Target year" = "black") | |
| # , | |
| # "Additional country" = "tan2") | |
| }) | |
| observeEvent(input$colorboxred,{ | |
| dataset$fill = c("Mortality deficit" = "indianred1","Excess mortality" = "red3") | |
| dataset$color = c("All available years" = "gray80", | |
| "Reference level" = "firebrick2", | |
| "Target year" = "black") | |
| # , | |
| # "Additional country" = "tomato") | |
| }) | |
| observeEvent(input$colorboxgreen,{ | |
| dataset$fill = c("Mortality deficit" = "palegreen","Excess mortality" = "forestgreen") | |
| dataset$color = c("All available years" = "gray80", | |
| "Reference level" = "olivedrab", | |
| "Target year" = "black") | |
| # , | |
| # "Additional country" = "darkseagreen") | |
| }) | |
| observeEvent(input$colorboxblue,{ | |
| dataset$fill = c("Mortality deficit" = "steelblue1","Excess mortality" = "steelblue") | |
| dataset$color = c("All available years" = "gray80", | |
| "Reference level" = "#66A0C4", | |
| "Target year" = "#2a4770") | |
| # , | |
| # "Additional country" = "slategray3") | |
| }) | |
| observeEvent(input$colorboxearth,{ | |
| dataset$fill = c("Mortality deficit" = "#E69F00","Excess mortality" = "darkorange3") | |
| dataset$color = c("All available years" = "gray80", | |
| "Reference level" = "forestgreen", | |
| "Target year" = "black") | |
| # , | |
| # "Additional country" = "slategray3") | |
| }) | |
| ### additional graph color | |
| dataset$fill2 = c("Mortality deficit" = "lightblue1","Excess mortality" = "darkorange2") | |
| dataset$color2 = c("All available years" = "gray80", | |
| "Reference level" = "#66A0C4", | |
| "Target year" = "black") | |
| # , | |
| # "Additional country" = "tan2") | |
| observeEvent(input$colorboxhmd2,{ | |
| dataset$fill2 = c("Mortality deficit" = "lightblue1","Excess mortality" = "darkorange2") | |
| dataset$color2 = c("All available years" = "gray80", | |
| "Reference level" = "#66A0C4", | |
| "Target year" = "black") | |
| # , | |
| # "Additional country" = "tan2") | |
| }) | |
| observeEvent(input$colorboxred2,{ | |
| dataset$fill2 = c("Mortality deficit" = "indianred1","Excess mortality" = "red3") | |
| dataset$color2 = c("All available years" = "gray80", | |
| "Reference level" = "firebrick2", | |
| "Target year" = "black") | |
| # , | |
| # "Additional country" = "tomato") | |
| }) | |
| observeEvent(input$colorboxgreen2,{ | |
| dataset$fill2 = c("Mortality deficit" = "palegreen","Excess mortality" = "forestgreen") | |
| dataset$color2 = c("All available years" = "gray80", | |
| "Reference level" = "olivedrab", | |
| "Target year" = "black") | |
| # , | |
| # "Additional country" = "darkseagreen") | |
| }) | |
| observeEvent(input$colorboxblue2,{ | |
| dataset$fill2 = c("Mortality deficit" = "steelblue1","Excess mortality" = "steelblue") | |
| dataset$color2 = c("All available years" = "gray80", | |
| "Reference level" = "#66A0C4", | |
| "Target year" = "#2a4770") | |
| # , | |
| # "Additional country" = "slategray3") | |
| }) | |
| observeEvent(input$colorboxearth2,{ | |
| dataset$fill2 = c("Mortality deficit" = "#E69F00","Excess mortality" = "darkorange3") | |
| dataset$color2 = c("All available years" = "gray80", | |
| "Reference level" = "forestgreen", | |
| "Target year" = "black") | |
| # , | |
| # "Additional country" = "slategray3") | |
| }) | |
| 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)) | |
| } | |
| dataset$myper=myper | |
| myvar=input$variable | |
| #### The baselines #### | |
| #### measures | |
| cols=colnames(data)[5:16] | |
| #### Weekly averages (across years) | |
| meandata=data[CountryCode %in% input$country & Year %in% c(myper), lapply(.SD,mean), .SDcols= cols, by = list(CountryCode,Week,Sex)] | |
| if ((53 %in% unique(data[CountryCode %in% input$country & Year ==input$targetyear]$Week)) & 52 %in% unique(meandata$Week) & !(53 %in% unique(meandata$Week))) { | |
| w52d=meandata[Week==52] | |
| w52d$Week=53 | |
| meandata=rbind(meandata,w52d) | |
| } | |
| dataset$meandata=meandata | |
| #### Expected level (average of weekly averages) | |
| 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(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(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(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(myper), lapply(.SD, quantile, prob=0.25), .SDcols = cols, by = list(CountryCode,Sex)] | |
| #### linear trend expectation | |
| 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) | |
| res=predict.lm(eq,data.frame(Year=as.numeric(input$targetyear))) | |
| res[res<0]=0 | |
| data.table(res,Year=input$targetyear,Sex=x$Sex[1],CountryCode=x$CountryCode[1],Week=x$Week[1]) | |
| } )) | |
| colnames(linex)[1]=paste(myvar) | |
| if ((53 %in% unique(data[CountryCode %in% input$country & Year ==input$targetyear]$Week)) & 52 %in% unique(linex$Week) & !(53 %in% unique(linex$Week))) { | |
| w52l=linex[Week==52] | |
| w52l$Week=53 | |
| linex=rbind(linex,w52l) | |
| } | |
| if (input$extracountry == TRUE) { | |
| if (input$viewlength == "Continuous") { | |
| myper2 = c(input$period2[1]:input$period2[2]) | |
| } else if (input$viewlength2 == "Multi-year") { | |
| myper2 = as.numeric(sort(input$multiperiod2)) | |
| } | |
| dataset$myper2=myper2 | |
| meandata2=data[CountryCode %in% input$country2 & Year %in% myper2, lapply(.SD,mean), .SDcols= cols, by = list(CountryCode,Week,Sex)] | |
| if ((53 %in% unique(data[CountryCode %in% input$country2 & Year ==input$targetyear2]$Week)) & 52 %in% unique(meandata2$Week) & !(53 %in% unique(meandata2$Week))) { | |
| w52d2=meandata2[Week==52] | |
| w52d2$Week=53 | |
| meandata2=rbind(meandata2,w52d2) | |
| } | |
| dataset$meandata2=meandata2 | |
| #### Expected level (average of weekly averages) | |
| 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% 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% 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% 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% myper2, lapply(.SD, quantile, prob=0.25), .SDcols = cols, by = list(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))) | |
| res[res<0]=0 | |
| data.table(res,Year=input$targetyear2,Sex=x$Sex[1],CountryCode=x$CountryCode[1],Week=x$Week[1]) | |
| } )) | |
| colnames(linex2)[1]=paste(myvar) | |
| if ((53 %in% unique(data[CountryCode %in% input$country2 & Year ==input$targetyear2]$Week)) & 52 %in% unique(linex2$Week) & !(53 %in% unique(linex2$Week))) { | |
| w52l2=linex2[Week==52] | |
| w52l2$Week=53 | |
| linex2=rbind(linex2,w52l2) | |
| } | |
| } | |
| week1=unique(data[CountryCode==input$country & Year==input$targetyear]$Week) | |
| week2=unique(meandata[CountryCode==input$country]$Week) | |
| commonweek=intersect(week1,week2) | |
| if (input$extracountry == TRUE) { | |
| week3=unique(data[CountryCode==input$country2 & Year==input$targetyear2]$Week) | |
| week4=unique(meandata2[CountryCode==input$country2]$Week) | |
| commonweek2=intersect(week3,week4) | |
| } | |
| if (input$area == "Week-specific Averages"){ | |
| ### weeks in target year | |
| subdata=data[CountryCode==input$country & Year==input$targetyear & Week %in% commonweek] | |
| mydat=meandata[CountryCode==input$country & Week %in% commonweek] | |
| setorder(mydat,"Week") | |
| subdata$diff=subdata[,..myvar]-mydat[,..myvar] | |
| subdata$yminvalue=subdata[,..myvar]-subdata$diff | |
| subdata$ymaxvalue = subdata[,..myvar] | |
| compareline = meandata[CountryCode == input$country, c("Sex","Week",..myvar)] | |
| #### country 2 #### | |
| if (input$extracountry == TRUE){ | |
| subdata2=data[CountryCode==input$country2 & Year==input$targetyear2 & Week %in% commonweek2] | |
| mydat2=meandata2[CountryCode==input$country2 & Week %in% commonweek2] | |
| setorder(mydat2,"Week") | |
| subdata2$diff=subdata2[,..myvar]-mydat2[,..myvar] | |
| subdata2$yminvalue=subdata2[,..myvar]-subdata2$diff | |
| subdata2$ymaxvalue = subdata2[,..myvar] | |
| compareline2 = meandata2[CountryCode == input$country2, c("Sex","Week",..myvar)] | |
| } | |
| } else if (input$area %in% c("Yearly Average-week","Summer Average-week","Yearly Lower-quartile-week")){ | |
| if (input$area == "Yearly Average-week"){ | |
| baseline = expectedlevel[CountryCode==input$country] | |
| if (input$extracountry == TRUE){ | |
| baseline2 = expectedlevel2[CountryCode==input$country2] | |
| } | |
| } else if (input$area == "Summer Average-week") { | |
| baseline = expectedlevelsummer[CountryCode==input$country] | |
| if (input$extracountry == TRUE){ | |
| baseline2 = expectedlevelsummer2[CountryCode==input$country2] | |
| } | |
| } else if (input$area == "Yearly Lower-quartile-week") { | |
| Qf=as.numeric(q25y[CountryCode %in% input$country & Sex == "f", ..myvar]) | |
| Qm=as.numeric(q25y[CountryCode %in% input$country & Sex == "m", ..myvar]) | |
| Qb=as.numeric(q25y[CountryCode %in% input$country & Sex == "b", ..myvar]) | |
| q25allsel=rbind( | |
| data[CountryCode %in% input$country & Year %in% c(myper) & Sex == "m",c("CountryCode", "Year","Week","Sex",..myvar)][which(data[CountryCode %in% input$country & Year %in% c(myper) & Sex == "m",..myvar]<Qm)], | |
| data[CountryCode %in% input$country & Year %in% c(myper) & Sex == "f",c("CountryCode", "Year","Week","Sex",..myvar)][which(data[CountryCode %in% input$country & Year %in% c(myper) & Sex == "f",..myvar]<Qf)], | |
| data[CountryCode %in% input$country & Year %in% c(myper) & Sex == "b",c("CountryCode", "Year","Week","Sex",..myvar)][which(data[CountryCode %in% input$country & Year %in% c(myper) & Sex == "b",..myvar]<Qb)] | |
| ) | |
| colnow=colnames(q25allsel[,5]) | |
| baseline=q25allsel[, lapply(.SD,mean), .SDcols=colnow, by = list(CountryCode,Sex)] | |
| if (input$extracountry == TRUE){ | |
| Qf2=as.numeric(q25y2[CountryCode %in% input$country2 & Sex == "f", ..myvar]) | |
| Qm2=as.numeric(q25y2[CountryCode %in% input$country2 & Sex == "m", ..myvar]) | |
| Qb2=as.numeric(q25y2[CountryCode %in% input$country2 & Sex == "b", ..myvar]) | |
| q25allsel2=rbind( | |
| data[CountryCode %in% input$country2 & Year %in% myper2 & Sex == "m",c("CountryCode", "Year","Week","Sex",..myvar)][which(data[CountryCode %in% input$country2 & Year %in% myper2 & Sex == "m",..myvar]<Qm2)], | |
| data[CountryCode %in% input$country2 & Year %in% myper2 & Sex == "f",c("CountryCode", "Year","Week","Sex",..myvar)][which(data[CountryCode %in% input$country2 & Year %in% myper2 & Sex == "f",..myvar]<Qf2)], | |
| data[CountryCode %in% input$country2 & Year %in% myper2 & Sex == "b",c("CountryCode", "Year","Week","Sex",..myvar)][which(data[CountryCode %in% input$country2 & Year %in% myper2 & Sex == "b",..myvar]<Qb2)] | |
| ) | |
| colnow2=colnames(q25allsel2[,5]) | |
| baseline2=q25allsel2[, lapply(.SD,mean), .SDcols=colnow2, by = list(CountryCode,Sex)] | |
| } | |
| } | |
| ### weeks in target year | |
| week1=unique(data[CountryCode==input$country & Year==input$targetyear]$Week) | |
| if (max(week1) == 53) { | |
| week2 = 1:53 | |
| } else { | |
| week2 = 1:52 | |
| } | |
| commonweek=intersect(week1,week2) | |
| subdata=data[CountryCode==input$country & Year==input$targetyear & Week %in% commonweek] | |
| subdata$diff=subdata[,..myvar]-rep(unlist(baseline[,..myvar]),length(commonweek)) | |
| subdata$yminvalue=subdata[,..myvar]-subdata$diff | |
| subdata$ymaxvalue = subdata[,..myvar] | |
| compareline = data.table( | |
| baseline[rep(baseline[, .I],3)], | |
| Week = rep(1:max(week2),each=3) | |
| ) | |
| if (input$extracountry == TRUE){ | |
| week3=unique(data[CountryCode==input$country2 & Year==input$targetyear2]$Week) | |
| if (max(week3) == 53) { | |
| week4 = 1:53 | |
| } else { | |
| week4 = 1:52 | |
| } | |
| commonweek2=intersect(week3,week4) | |
| subdata2=data[CountryCode==input$country2 & Year==input$targetyear2 & Week %in% commonweek2] | |
| subdata2$diff=subdata2[,..myvar]-rep(unlist(baseline2[,..myvar]),length(commonweek2)) | |
| subdata2$yminvalue=subdata2[,..myvar]-subdata2$diff | |
| subdata2$ymaxvalue = subdata2[,..myvar] | |
| compareline2 = data.table( | |
| baseline2[rep(baseline2[, .I],3)], | |
| Week = rep(1:max(week4),each=3) | |
| ) | |
| } | |
| } else if (input$area == "Week-specific Trends"){ | |
| week2 = unique(linex$Week) | |
| commonweek=intersect(week1,week2) | |
| subdata=data[CountryCode==input$country & Year==input$targetyear & Week %in% commonweek] | |
| mydat=linex[Week %in% commonweek] | |
| setorder(mydat,Sex,Week) | |
| setorder(subdata,Sex,Week) | |
| subdata$diff=subdata[,..myvar]-mydat[,..myvar] | |
| subdata$yminvalue=subdata[,..myvar]-subdata$diff | |
| subdata$ymaxvalue = subdata[,..myvar] | |
| compareline = linex[CountryCode == input$country, c("Sex","Week",..myvar)] | |
| if (input$extracountry == TRUE) { | |
| week4 = unique(linex2$Week) | |
| commonweek2=intersect(week3,week4) | |
| subdata2=data[CountryCode==input$country2 & Year==input$targetyear2 & Week %in% commonweek2] | |
| mydat2=linex2[Week %in% commonweek2] | |
| setorder(mydat2,Sex,Week) | |
| setorder(subdata2,Sex,Week) | |
| subdata2$diff=subdata2[,..myvar]-mydat2[,..myvar] | |
| subdata2$yminvalue=subdata2[,..myvar]-subdata2$diff | |
| subdata2$ymaxvalue = subdata2[,..myvar] | |
| compareline2 = linex2[CountryCode == input$country2, c("Sex","Week",..myvar)] | |
| } | |
| } else if (input$area =="Week-specific Lower Quartiles"){ | |
| subdata=data[CountryCode==input$country & Year==input$targetyear & Week %in% commonweek] | |
| mydat=q25data[CountryCode==input$country & Week %in% commonweek] | |
| if (max(subdata$Week)==53 & max(mydat$Week)!=53) { | |
| m52da=mydat[Week==52] | |
| m52da$Week=53 | |
| mydat=rbind(mydat,m52da) | |
| } | |
| setorder(mydat,"Week") | |
| subdata$diff=subdata[,..myvar]-mydat[,..myvar] | |
| subdata$yminvalue=subdata[,..myvar]-subdata$diff | |
| subdata$ymaxvalue = subdata[,..myvar] | |
| # compareline = q25data[CountryCode == input$country, c("Sex","Week",..myvar)] | |
| compareline = mydat[CountryCode == input$country, c("Sex","Week",..myvar)] | |
| #### country 2 #### | |
| if (input$extracountry == TRUE){ | |
| subdata2=data[CountryCode==input$country2 & Year==input$targetyear2 & Week %in% commonweek2] | |
| mydat2=q25data2[CountryCode==input$country2 & Week %in% commonweek2] | |
| if (max(subdata2$Week)==53 & max(mydat2$Week)!=53) { | |
| m52da2=mydat2[Week==52] | |
| m52da2$Week=53 | |
| mydat2=rbind(mydat2,m52da2) | |
| } | |
| setorder(mydat2,"Week") | |
| subdata2$diff=subdata2[,..myvar]-mydat2[,..myvar] | |
| subdata2$yminvalue=subdata2[,..myvar]-subdata2$diff | |
| subdata2$ymaxvalue = subdata2[,..myvar] | |
| compareline2 = mydat2[CountryCode == input$country2, c("Sex","Week",..myvar)] | |
| } | |
| } #else if (input$area =="Yearly Lower-quartile-week"){ | |
| # subdata=data[CountryCode==input$country & Year==input$targetyear & Week %in% commonweek] | |
| # Qf=as.numeric(q25y[CountryCode %in% input$country & Sex == "f", ..myvar]) | |
| # Qm=as.numeric(q25y[CountryCode %in% input$country & Sex == "m", ..myvar]) | |
| # Qb=as.numeric(q25y[CountryCode %in% input$country & Sex == "b", ..myvar]) | |
| # # data[CountryCode %in% "AUT" & Sex == "f",c("CountryCode", "Year","Week","Sex","D0_14")][which(data[CountryCode %in% "AUT" & Sex == "f","D0_14"]<Qf)] | |
| # q25allsel=rbind( | |
| # data[CountryCode %in% input$country & Year %in% c(myper) & Sex == "b",c("CountryCode", "Year","Week","Sex",..myvar)][which(data[CountryCode %in% input$country & Year %in% c(myper) & Sex == "b",..myvar]<Qb)], | |
| # data[CountryCode %in% input$country & Year %in% c(myper) & Sex == "f",c("CountryCode", "Year","Week","Sex",..myvar)][which(data[CountryCode %in% input$country & Year %in% c(myper) & Sex == "f",..myvar]<Qf)], | |
| # data[CountryCode %in% input$country & Year %in% c(myper) & Sex == "m",c("CountryCode", "Year","Week","Sex",..myvar)][which(data[CountryCode %in% input$country & Year %in% c(myper) & Sex == "m",..myvar]<Qm)]) | |
| # # print(q25allsel) | |
| # # expectedlevel=data[CountryCode %in% input$country & Year %in% c(myper), lapply(.SD,mean), .SDcols= cols, by = list(CountryCode,Sex)] | |
| # colnow=colnames(q25allsel[,5]) | |
| # # =q25allsel[, lapply(.SD,mean), .SDcols=colnow, by = list(CountryCode,Sex)]) | |
| # baseline=q25allsel[, lapply(.SD,mean), .SDcols=colnow, by = list(CountryCode,Sex)]) | |
| # # print(data[CountryCode %in% input$country & Sex == "b",][data[CountryCode %in% input$country & Sex == "b", ..myvar]<Qb,]) | |
| # # print(data[CountryCode==input$country & Year %in% c(myper) & Sex =="f" & ..myvar<q25y[CountryCode %in% input$country & Sex == "f", ..myvar]]) | |
| # } | |
| ### Makeup | |
| ### labeller | |
| measurechoices=c("Deaths, Total" = "DTotal", | |
| "Death Rate, Total" = "RTotal", | |
| "Deaths, Ages 0-14" = "D0_14", | |
| "Deaths, Ages 15-64" = "D15_64", | |
| "Deaths, Ages 65-74" = "D65_74", | |
| "Deaths, Ages 75-84" = "D75_84", | |
| "Deaths, Ages 85+" = "D85p", | |
| "Age-specific Death Rate, Ages 0-14" = "R0_14", | |
| "Age-specific Death Rate, Ages 15-64" = "R15_64", | |
| "Age-specific Death Rate, Ages 65-74" = "R65_74", | |
| "Age-specific Death Rate, Ages 75-84" = "R75_84", | |
| "Age-specific Death Rate, Ages 85+" = "R85p") | |
| dataset$measurechoices = measurechoices | |
| sexchoices = c("b" = "Total", | |
| "f" = "Female", | |
| "m" = "Male") | |
| sexchoices2 = c("Total" ="b", | |
| "Female" = "f", | |
| "Male" = "m") | |
| dataset$sexchoices = sexchoices2 | |
| countrychoices= countrylist | |
| dataset$countrychoices = countrychoices | |
| ### ribbon | |
| if (length(subdata[Sex=="m"]$Week)==1) {ribbon=subdata} else { | |
| ribbon = rbindlist(by(subdata,subdata$Sex, | |
| function(x){ | |
| newdata = data.table( | |
| Week = seq(x$Week[1],x$Week[length(x$Week)],length=1000), | |
| sapply(x[,c("diff","yminvalue","ymaxvalue")], | |
| function(T) approxfun(x$Week, T)(seq(x$Week[1],x$Week[length(x$Week)],length=1000))), | |
| Sex=x$Sex[1] | |
| ) | |
| } | |
| )) | |
| } | |
| ribbon$type=ifelse(ribbon$diff>=0,"Excess mortality","Mortality deficit") | |
| ribbon$group=rleid(ribbon$type) | |
| dataset$ribbon=ribbon | |
| subdata$type=ifelse(subdata$diff>=0,"Excess mortality","Mortality deficit") | |
| levels(subdata$Sex) = c("Total","Female","Male") | |
| dataset$subdata = subdata | |
| if (input$extracountry == TRUE){ | |
| ### ribbon | |
| if (length(subdata2[Sex=="m"]$Week)==1) {ribbon2=subdata2} else { | |
| ribbon2 = rbindlist(by(subdata2,subdata2$Sex, | |
| function(x){ | |
| newdata = data.table( | |
| Week = seq(x$Week[1],x$Week[length(x$Week)],length=1000), | |
| sapply(x[,c("diff","yminvalue","ymaxvalue")], | |
| function(T) approxfun(x$Week, T)(seq(x$Week[1],x$Week[length(x$Week)],length=1000))), | |
| Sex=x$Sex[1] | |
| ) | |
| } | |
| )) | |
| } | |
| ribbon2$type=ifelse(ribbon2$diff>=0,"Excess mortality","Mortality deficit") | |
| ribbon2$group=rleid(ribbon2$type) | |
| dataset$ribbon2=ribbon2 | |
| subdata2$type=ifelse(subdata2$diff>=0,"Excess mortality","Mortality deficit") | |
| levels(subdata2$Sex) = c("Total","Female","Male") | |
| dataset$subdata2 = subdata2 | |
| } | |
| #### plot figures | |
| if (is.null(input$sexchoice)) { | |
| return(NULL) | |
| } else { | |
| g=ggplot()+ | |
| facet_wrap(~Sex, labeller = labeller( Sex = sexchoices))+ | |
| ylab(paste(names(measurechoices)[measurechoices == input$variable]))+ | |
| scale_fill_manual("",values=dataset$fill, drop=FALSE)+ | |
| scale_color_manual("", values=dataset$color)+ | |
| scale_x_continuous(breaks= c(1, seq(5, 45, 5), 50, 52), labels=c(1, seq(5, 45, 5), "", 52),expand = c(0, 0))+ | |
| theme(legend.position="top", text=element_text(size=18),strip.background = element_rect(fill = "white"),axis.text.y=element_text(colour="black",margin=margin(l=10)), | |
| panel.spacing = unit(1.5, "lines"), plot.margin=margin(t = 0, r = 10, b = 0, l = 0, unit = "pt"), | |
| panel.background = element_rect(fill = "white", | |
| colour = "white", | |
| size = 0.5, linetype = "solid"), | |
| panel.grid.major = element_line(size = 0.5, linetype = 'solid', | |
| colour = "gray90"), | |
| panel.grid.minor = element_line(size = 0.25, linetype = 'solid', | |
| colour = "white"))+ | |
| guides(fill = guide_legend(override.aes = list(colour = "black"))) | |
| if (input$variable %in% measurechoices[c(2,8:12)]){ | |
| g= g + scale_y_continuous(breaks=pretty(c(min( | |
| data[CountryCode %in% c(input$country) & Sex %in% input$sexchoice,..myvar], | |
| compareline[Sex %in% input$sexchoice,..myvar]), | |
| max(data[CountryCode %in% c(input$country) & Sex %in% input$sexchoice,..myvar], | |
| compareline[Sex %in% input$sexchoice,..myvar])), n=15), labels=function(x) format(100000*x)) | |
| } else { | |
| g= g + scale_y_continuous(breaks=pretty(c(min( | |
| data[CountryCode %in% c(input$country) & Sex %in% input$sexchoice,..myvar], | |
| compareline[Sex %in% input$sexchoice,..myvar]), | |
| max(data[CountryCode %in% c(input$country) & Sex %in% input$sexchoice,..myvar], | |
| compareline[Sex %in% input$sexchoice,..myvar])), n=15)) | |
| } | |
| if (input$extracountry == TRUE){ | |
| req(input$country2,input$targetyear2,input$period2) | |
| yminval=min( | |
| data[CountryCode %in% c(input$country2) & Sex %in% input$sexchoice & Year == input$targetyear2,..myvar], | |
| data[CountryCode %in% c(input$country) & Sex %in% input$sexchoice & Year == input$targetyear,..myvar], | |
| compareline[Sex %in% input$sexchoice,..myvar],compareline2[Sex %in% input$sexchoice,..myvar]) | |
| ymaxval=max( | |
| data[CountryCode %in% c(input$country2) & Sex %in% input$sexchoice & Year == input$targetyear2,..myvar], | |
| data[CountryCode %in% c(input$country) & Sex %in% input$sexchoice & Year == input$targetyear,..myvar], | |
| compareline[Sex %in% input$sexchoice,..myvar],compareline2[Sex %in% input$sexchoice,..myvar]) | |
| if (input$variable %in% measurechoices[c(2,8:12)]){ | |
| g = g + scale_y_continuous(breaks=pretty(c(yminval,ymaxval), n=15), limits=c(yminval,ymaxval),labels=function(x) format(100000*x)) | |
| } else { | |
| g = g + scale_y_continuous(breaks=pretty(c(yminval,ymaxval), n=15), limits=c(yminval,ymaxval)) | |
| } | |
| h = g + ylab(paste(names(measurechoices)[measurechoices == input$variable],", ",names(countrychoices)[countrychoices == input$country2], sep=""))+ | |
| scale_color_manual("",labels=c("Target year" = paste("Target year",input$targetyear2), | |
| "Reference level" = paste("Reference level ", min(dataset$myper2),"-",max(dataset$myper2),sep=""), | |
| # "Reference level" = paste("Reference level ", input$period2[1],"-",input$period2[2],sep=""), | |
| "All available years" = "All available years"#, | |
| # "Additional country" = "Additional country" | |
| ),values=dataset$color2)+ | |
| scale_fill_manual("",values=dataset$fill2, drop=FALSE) | |
| g = g + ylab(paste(names(measurechoices)[measurechoices == input$variable],", ",names(countrychoices)[countrychoices == input$country], sep=""))+ | |
| scale_color_manual("",labels=c("Target year" = paste("Target year",input$targetyear), | |
| "Reference level" = paste("Reference level ", min(dataset$myper),"-",max(dataset$myper),sep=""), | |
| "All available years" = "All available years"#, | |
| #"Additional country" = "Additional country" | |
| ),values=dataset$color)+ | |
| scale_fill_manual("",values=dataset$fill, drop=FALSE) | |
| } | |
| if (input$alldata == TRUE) { | |
| g= g + geom_line(data=data[CountryCode==input$country & Sex %in% input$sexchoice],aes_string(x="Week",y=input$variable,group="Year", color=shQuote("All available years"))) | |
| if (input$extracountry == TRUE){ | |
| yminval=min(data[CountryCode %in% c(input$country,input$country2) & Sex %in% input$sexchoice,..myvar], | |
| compareline[Sex %in% input$sexchoice,..myvar],compareline2[Sex %in% input$sexchoice,..myvar]) | |
| ymaxval=max( | |
| data[CountryCode %in% c(input$country,input$country2) & Sex %in% input$sexchoice,..myvar], | |
| compareline[Sex %in% input$sexchoice,..myvar],compareline2[Sex %in% input$sexchoice,..myvar]) | |
| if (input$variable %in% measurechoices[c(2,8:12)]){ | |
| g = g + scale_y_continuous(breaks=pretty(c(yminval,ymaxval), n=15), limits=c(yminval,ymaxval),labels=function(x) format(100000*x))#+ | |
| h = h + geom_line(data=data[CountryCode==input$country2 & Sex %in% input$sexchoice],aes_string(x="Week",y=input$variable,group="Year", color=shQuote("All available years")))+ | |
| scale_y_continuous(breaks=pretty(c(yminval,ymaxval), n=15), limits=c(yminval,ymaxval),labels=function(x) format(100000*x)) | |
| dataset$h = h | |
| } else { | |
| g = g + scale_y_continuous(breaks=pretty(c(yminval,ymaxval), n=15), limits=c(yminval,ymaxval))#+ | |
| h = h + geom_line(data=data[CountryCode==input$country2 & Sex %in% input$sexchoice],aes_string(x="Week",y=input$variable,group="Year", color=shQuote("All available years")))+ | |
| scale_y_continuous(breaks=pretty(c(yminval,ymaxval), n=15), limits=c(yminval,ymaxval)) | |
| dataset$h = h | |
| } | |
| } | |
| } | |
| if (input$extracountry == TRUE){ | |
| h = h + geom_ribbon(data=ribbon2[Sex %in% input$sexchoice],aes(x=Week,ymin= yminvalue, ymax = ymaxvalue, fill=type,group=group))+ | |
| geom_line(data=data[CountryCode==input$country2 & Year==input$targetyear2 & Sex %in% input$sexchoice],aes_string(x="Week",y=input$variable, color=shQuote("Target year")), size=1.2)+ | |
| geom_line(data=compareline2[Sex %in% input$sexchoice], aes_string(x="Week",y=input$variable, color=shQuote("Reference level")), size=1.2)+ | |
| theme(legend.position = "bottom")+ | |
| theme(strip.background = element_blank(),strip.text.x = element_text(color="white"))+ | |
| ggtitle(paste(names(countrychoices)[countrychoices == input$country2]))+ | |
| theme(plot.title = element_text(hjust = 0.5)) | |
| dataset$h = h | |
| } | |
| g = g + geom_ribbon(data=ribbon[Sex %in% input$sexchoice],aes(x=Week,ymin= yminvalue, ymax = ymaxvalue, fill=type,group=group))+ | |
| geom_line(data=data[CountryCode==input$country & Year==input$targetyear & Sex %in% input$sexchoice],aes_string(x="Week",y=input$variable, color=shQuote("Target year")), size=1.2)+ | |
| geom_line(data=compareline[Sex %in% input$sexchoice], aes_string(x="Week",y=input$variable, color=shQuote("Reference level")), size=1.2)+ | |
| ggtitle(paste(names(countrychoices)[countrychoices == input$country]))+ | |
| theme(plot.title = element_text(hjust = 0.5)) | |
| g | |
| } | |
| }) | |
| # extra figure | |
| output$extracountryfigure = renderPlot({ | |
| if (input$extracountry == FALSE) {return(NULL)} else { dataset$h } | |
| }) | |
| # click info figure 1 | |
| output$click_info = renderUI({ | |
| req(input$plot_click) | |
| if (input$alldata == FALSE) {return(NULL)} else { | |
| req(input$plot_click) | |
| if (is.null(input$plot_click)) {return(NULL)} else { | |
| point = nearPoints(data[CountryCode==input$country & Sex %in% input$sexchoice], input$plot_click, threshold = 10, maxpoints = 1, addDist = TRUE) | |
| if (dim(point)[1]==0) {return(NULL)} else { | |
| if (grepl("R", input$variable, fixed = TRUE)==TRUE) { | |
| # HTML(paste0('This data point for ', names(dataset$countrychoices)[dataset$countrychoices == input$country],' is in year ', point$Year, ", week ", point$Week, " with ", | |
| # paste(names(dataset$measurechoices)[dataset$measurechoices == input$variable]), " = ",sprintf("%0.6f",point[[input$plot_click$mapping$y]]), " for ", names(dataset$sexchoices)[dataset$sexchoices == input$plot_click$panelvar1], " population.")) | |
| HTML(paste0('This data point for ', names(dataset$countrychoices)[dataset$countrychoices == input$country],' is in year ', point$Year, ", week ", point$Week, " with ", | |
| paste(names(dataset$measurechoices)[dataset$measurechoices == input$variable]), " = ",as.integer(point[[input$plot_click$mapping$y]]*100000), " per 100000 person-years for ", names(dataset$sexchoices)[dataset$sexchoices == input$plot_click$panelvar1], " population.")) | |
| } else { | |
| HTML(paste0('This data point for ', names(dataset$countrychoices)[dataset$countrychoices == input$country],' is in year ', point$Year, ", week ", point$Week, " with ", | |
| paste(names(dataset$measurechoices)[dataset$measurechoices == input$variable]), " = ",as.integer(point[[input$plot_click$mapping$y]]), " for ", names(dataset$sexchoices)[dataset$sexchoices == input$plot_click$panelvar1], " population.")) | |
| } | |
| } | |
| } | |
| } | |
| }) | |
| # click info figure 2 | |
| output$click_info2 = renderUI({ | |
| req(input$plot_click2) | |
| if (input$alldata == FALSE) {return(NULL)} else { | |
| req(input$plot_click2) | |
| if (is.null(input$plot_click2)) {return(NULL)} else { | |
| point = nearPoints(data[CountryCode==input$country2 & Sex %in% input$sexchoice], input$plot_click2, threshold = 10, maxpoints = 1, addDist = TRUE) | |
| if (dim(point)[1]==0) {return(NULL)} else { | |
| if (grepl("R", input$variable, fixed = TRUE)==TRUE) { | |
| # HTML(paste0('This data point for ', names(dataset$countrychoices)[dataset$countrychoices == input$country2],' is in year ', point$Year, ", week ", point$Week, " with ", | |
| # paste(names(dataset$measurechoices)[dataset$measurechoices == input$variable]), " = ",sprintf("%0.6f",point[[input$plot_click2$mapping$y]]), " for ", names(dataset$sexchoices)[dataset$sexchoices == input$plot_click2$panelvar1], " population.")) | |
| HTML(paste0('This data point for ', names(dataset$countrychoices)[dataset$countrychoices == input$country2],' is in year ', point$Year, ", week ", point$Week, " with ", | |
| paste(names(dataset$measurechoices)[dataset$measurechoices == input$variable]), " = ",as.integer(point[[input$plot_click2$mapping$y]]*100000), " per 100000 person-years for ", names(dataset$sexchoices)[dataset$sexchoices == input$plot_click2$panelvar1], " population.")) | |
| } else { | |
| HTML(paste0('This data point for ', names(dataset$countrychoices)[dataset$countrychoices == input$country2],' is in year ', point$Year, ", week ", point$Week, " with ", | |
| paste(names(dataset$measurechoices)[dataset$measurechoices == input$variable]), " = ",as.integer(point[[input$plot_click2$mapping$y]]), " for ", names(dataset$sexchoices)[dataset$sexchoices == input$plot_click2$panelvar1], " population.")) | |
| } | |
| } | |
| } | |
| } | |
| }) | |
| # hover info figure 1 | |
| output$hover_info = renderUI({ | |
| req(dataset$ribbon) | |
| req(input$plot_hover) | |
| if (is.null(input$sexchoice)) { | |
| return(NULL) } else { | |
| if (input$plot_hover$x >= max(dataset$ribbon$Week)) {return(NULL)} else { | |
| hover = input$plot_hover | |
| point=dataset$ribbon[Week >= as.integer(input$plot_hover$x) & Week < as.integer(input$plot_hover$x)+1] | |
| if (nrow(point) == 0) {return(NULL)} else { | |
| left_pct = (hover$x - hover$domain$left) / (hover$domain$right - hover$domain$left) | |
| top_pct = (hover$domain$top - hover$y) / (hover$domain$top - hover$domain$bottom) | |
| left_px = hover$range$left + left_pct * (hover$range$right - hover$range$left) | |
| top_px = hover$range$top + top_pct * (hover$range$bottom - hover$range$top) | |
| style = paste0("position:absolute; z-index:100; background-color: rgba(245, 245, 245, 0.85); | |
| padding:5px 5px 0px 5px;border-radius:5px; | |
| box-shadow: 0 4px 8px 0 rgba(0, 0, 0, 0.2), 0 6px 20px 0 rgba(0, 0, 0, 0.19);", | |
| "left:", left_px + 8, "px; top:", top_px + 8, "px;") | |
| hovergroup=unique(dataset$ribbon[Week >= as.integer(input$plot_hover$x) & Week < as.integer(input$plot_hover$x)+1]$group) | |
| polyinfo=dataset$ribbon[group %in% hovergroup, .(weekmin=min(Week),weekmax=max(Week)), by=.(Sex,type,group)] | |
| polyinfo=polyinfo[input$plot_hover$x >=weekmin & input$plot_hover$x <=weekmax,] | |
| iw0=as.integer(polyinfo[Sex==hover$panelvar1]$weekmin):as.integer(polyinfo[Sex==hover$panelvar1]$weekmax) | |
| iw=range(iw0[iw0>=polyinfo[Sex==hover$panelvar1]$weekmin]) | |
| if (iw[1]==iw[2]){ | |
| tags$div(style=style, | |
| p(HTML(paste0("This ", tolower(as.character(polyinfo[Sex==hover$panelvar1]$type)) , | |
| " is on week ", iw[1], "."))) | |
| ) | |
| } else { | |
| tags$div(style=style, | |
| p(HTML(paste0("This ", tolower(as.character(polyinfo[Sex==hover$panelvar1]$type)) , | |
| " is between weeks ", iw[1], | |
| " and ", iw[2], "; and ", iw[2]-iw[1]+1, " weeks long."))) | |
| ) | |
| } | |
| } | |
| } | |
| } | |
| }) | |
| output$hover_info2 = renderUI({ | |
| req(dataset$ribbon2) | |
| req(input$plot_hover2) | |
| if (is.null(input$sexchoice)) { | |
| return(NULL) } else { | |
| if (input$plot_hover2$x >= max(dataset$ribbon2$Week)) {return(NULL)} else { | |
| hover = input$plot_hover2 | |
| point=dataset$ribbon2[Week >= as.integer(input$plot_hover2$x) & Week < as.integer(input$plot_hover2$x)+1] | |
| if (nrow(point) == 0) {return(NULL)} else { | |
| left_pct = (hover$x - hover$domain$left) / (hover$domain$right - hover$domain$left) | |
| top_pct = (hover$domain$top - hover$y) / (hover$domain$top - hover$domain$bottom) | |
| left_px = hover$range$left + left_pct * (hover$range$right - hover$range$left) | |
| top_px = hover$range$top + top_pct * (hover$range$bottom - hover$range$top) | |
| style = paste0("position:absolute; z-index:100; background-color: rgba(245, 245, 245, 0.85); | |
| padding:5px 5px 0px 5px;border-radius:5px; | |
| box-shadow: 0 4px 8px 0 rgba(0, 0, 0, 0.2), 0 6px 20px 0 rgba(0, 0, 0, 0.19);", | |
| "left:", left_px + 8, "px; top:", top_px + 8, "px;") | |
| hovergroup=unique(dataset$ribbon2[Week >= as.integer(input$plot_hover2$x) & Week < as.integer(input$plot_hover2$x)+1]$group) | |
| polyinfo=dataset$ribbon2[group %in% hovergroup, .(weekmin=min(Week),weekmax=max(Week)), by=.(Sex,type,group)] | |
| polyinfo=polyinfo[input$plot_hover2$x >=weekmin & input$plot_hover2$x <=weekmax,] | |
| iw0=as.integer(polyinfo[Sex==hover$panelvar1]$weekmin):as.integer(polyinfo[Sex==hover$panelvar1]$weekmax) | |
| iw=range(iw0[iw0>=polyinfo[Sex==hover$panelvar1]$weekmin]) | |
| if (iw[1]==iw[2]){ | |
| tags$div(style=style, | |
| p(HTML(paste0("This ", tolower(as.character(polyinfo[Sex==hover$panelvar1]$type)) , | |
| " is on week ", iw[1], "."))) | |
| ) | |
| } else { | |
| tags$div(style=style, | |
| p(HTML(paste0("This ", tolower(as.character(polyinfo[Sex==hover$panelvar1]$type)) , | |
| " is between weeks ", iw[1], | |
| " and ", iw[2], "; and ", iw[2]-iw[1]+1, " weeks long."))) | |
| ) | |
| } | |
| } | |
| } | |
| } | |
| }) | |
| # brushedweeks info figure 1 | |
| output$brushedweeks = renderUI({ | |
| req(input$country,input$plot1_brush) | |
| subdataweek = dataset$subdata[Week >= input$plot1_brush$xmin & Week <= input$plot1_brush$xmax] | |
| if (dim(subdataweek)[1]==0){ | |
| p(HTML("No comparison available.")) | |
| } else { | |
| tags$div( | |
| p(HTML(paste0("The selection in ", names(dataset$countrychoices)[dataset$countrychoices == input$country], " is between weeks ", min(subdataweek$Week), " and ", max(subdataweek$Week), " for the year ", input$targetyear, " compared to the period of ", min(dataset$myper), "-", max(dataset$myper), "."))) | |
| ) | |
| } | |
| }) | |
| # brushedweeks info figure 2 | |
| output$brushedweeks2 = renderUI({ | |
| req(input$country,input$plot2_brush) | |
| subdataweek2 = dataset$subdata2[Week >= input$plot2_brush$xmin & Week <= input$plot2_brush$xmax] | |
| if (dim(subdataweek2)[1]==0){ | |
| p(HTML("No comparison available.")) | |
| } else { | |
| tags$div( | |
| p(HTML(paste0("The selection in ", names(dataset$countrychoices)[dataset$countrychoices == input$country2], " is between weeks ", min(subdataweek2$Week), " and ", max(subdataweek2$Week), " for the year ", input$targetyear2, " compared to the period of ", min(dataset$myper2), "-", max(dataset$myper2), "."))) | |
| ) | |
| } | |
| }) | |
| # brush info figure 1 | |
| output$brush_info = renderTable(striped = TRUE, hover = TRUE, bordered = TRUE, digits =NULL, align = "c", | |
| { | |
| req(input$country,input$plot1_brush) | |
| subdataweek = dataset$subdata[Week >= input$plot1_brush$xmin & Week <= input$plot1_brush$xmax] | |
| if (dim(subdataweek)[1]==0){ | |
| return(NULL) | |
| } else { | |
| HTML( | |
| paste( | |
| "Summary statistics"," | |
| \nbetween weeks ", min(subdataweek$Week), " and ", max(subdataweek$Week), | |
| "\nfor the year ", input$targetyear, " compared to the period of ", min(dataset$myper), "-", max(dataset$myper), ":\n", | |
| sep="") | |
| ) | |
| if (grepl("R", input$variable, fixed = TRUE)==TRUE) { | |
| sdw=subdataweek[,.(#"Average Death Rate"=sprintf("%0.6f",mean(diff)), | |
| #"Average, Target" = sprintf("%0.6f",mean(ymaxvalue)), | |
| #"Average, Reference" = sprintf("%0.6f",mean(yminvalue)) | |
| "Average Death Rate"= round(mean(diff)*100000,2), | |
| "Average, Target" = round(mean(ymaxvalue)*100000,2), | |
| "Average, Reference" = round(mean(yminvalue)*100000,2), | |
| "ADR/Reference (%)" = round( mean(diff)/mean(yminvalue)*100,2) | |
| ),by=.(Sex,type)] | |
| setorder(sdw,Sex) | |
| colnames(sdw)[2]="Difference" | |
| } else { | |
| sdw=subdataweek[,.(Deaths=as.integer(sum(diff)), | |
| "Deaths, Target" = as.integer(sum(ymaxvalue)), | |
| "Deaths, Reference" = as.integer(sum(yminvalue)), | |
| "Deaths/Reference (%)" = round(sum(diff)/sum(yminvalue)*100,2) | |
| ),by=.(Sex,type)] | |
| setorder(sdw,Sex) | |
| colnames(sdw)[2]="Difference" | |
| } | |
| # sdw$news = ifelse(sdw$Sex == "Total", "Total", ifelse(sdw$Sex == "Female", "Female", "Male")) | |
| sdw$news = ifelse(sdw$Sex == "b", "Total", ifelse(sdw$Sex == "f", "Female", "Male")) | |
| # sdwsub=sdw[,c(6,2:5)] | |
| sdwsub=sdw[,c(7,2:6)] | |
| colnames(sdwsub)[1]="Sex" | |
| sdwsub | |
| } | |
| }) | |
| output$brush_info2 = renderTable(striped = TRUE, hover = TRUE, bordered = TRUE, digits =NULL, align = "c", | |
| { | |
| req(input$country2,input$plot2_brush) | |
| subdataweek2 = dataset$subdata2[Week >= input$plot2_brush$xmin & Week <= input$plot2_brush$xmax] | |
| if (dim(subdataweek2)[1]==0){ | |
| return(NULL) | |
| } else { | |
| HTML( | |
| paste( | |
| "Summary statistics"," | |
| \nbetween weeks ", min(subdataweek2$Week), " and ", max(subdataweek2$Week), | |
| "\nfor the year ", input$targetyear2, " compared to the period of ", min(dataset$myper2), "-", max(dataset$myper2), ":\n", | |
| sep="") | |
| ) | |
| if (grepl("R", input$variable, fixed = TRUE)==TRUE) { | |
| sdw=subdataweek2[,.(#"Average Death Rate"=sprintf("%0.6f",mean(diff)), | |
| #"Average, Target" = sprintf("%0.6f",mean(ymaxvalue)), | |
| #"Average, Reference" = sprintf("%0.6f",mean(yminvalue)) | |
| "Average Death Rate"= round(mean(diff)*100000,2), | |
| "Average, Target" = round(mean(ymaxvalue)*100000,2), | |
| "Average, Reference" = round(mean(yminvalue)*100000,2), | |
| "ADR/Reference (%)" = round( mean(diff)/mean(yminvalue)*100,2) | |
| ),by=.(Sex,type)] | |
| setorder(sdw,Sex) | |
| colnames(sdw)[2]="Difference" | |
| } else { | |
| sdw=subdataweek2[,.(Deaths=as.integer(sum(diff)), | |
| "Deaths, Target" = as.integer(sum(ymaxvalue)), | |
| "Deaths, Reference" = as.integer(sum(yminvalue)), | |
| "Deaths/Reference (%)" = round(sum(diff)/sum(yminvalue)*100,2) | |
| ),by=.(Sex,type)] | |
| setorder(sdw,Sex) | |
| colnames(sdw)[2]="Difference" | |
| } | |
| # sdw$news = ifelse(sdw$Sex == "Total", "Total", ifelse(sdw$Sex == "Female", "Female", "Male")) | |
| sdw$news = ifelse(sdw$Sex == "b", "Total", ifelse(sdw$Sex == "f", "Female", "Male")) | |
| # sdwsub=sdw[,c(6,2:5)] | |
| sdwsub=sdw[,c(7,2:6)] | |
| colnames(sdwsub)[1]="Sex" | |
| sdwsub | |
| } | |
| }) | |
| } | |
| # runApp | |
| shinyApp(ui=ui,server=server) |