Ruori

Tämä sivu on tietokide alatyypiltään arviointi. Sivutunniste: Op_fi5889
Moderaattori:Jouni (katso kaikki) Sivun edistymistä ei ole arvioitu. Arvostuksen määrää ei ole arvioitu (ks. peer review).
Lisää dataa {{#opasnet_base_link:Op_fi5889}}

Ruori on VN-TEAS-hanke, jossa arvioidaan erilaisia ruokaan liittyviä riskitekijöitä, niiden vähentämispotentiaalia ja niiden terveys- ja talousvaikutuksia.

Rajaus

Kysymys

Millaista tautitaakkaa Suomessa aiheuttavat Ruori-altisteet (tyydyttynyt rasva, vähäiset vihannekset, vähäiset hedelmät, liiallnen suola, dioksiinit, lyijy, toksoplasma, norovirus ja legionella?

Aikataulu ja käyttäjät

Hanke alkoi 2018 ja loppuu 30.6.2019.
Toteuttajina ovat Ruokavirasto, THL ja Helsingin yliopisto.
Seuraavat skenaariot ovat tarkastelussa:

Vastaus

Vastaus kirjoitetaan tähän pian.

Perustelut

Data

Mitä kaikkea kuuluu vähäiseen hedelmien tai vihannesten syöntiin?

Vähähedelmäinen ruokavalio: hedelmien kulutus alle 3 annosta päivässä (310 g yhteensä) (sisältää tuoreet, pakastetut, keitetyt, säilötyt ja kuivatut hedelmät mutta ei sisällä hedelmämehuja tai suolaan tai etikkaan säilöttyjä hedelmiä) http://www.healthdata.org/terms-defined. Diet low in fruits: Consumption of less than 3 servings (310 g total) of fruits per day (includes fresh, frozen, cooked, canned, or dried fruit but excludes fruit juices and salted or pickled fruits).
Vähävihanneksinen ruokavalio: vihannesten kulutus alle 4 annosta (400 g yhteensä) (sisältää tuoreet, pakastetut, keitetyt, säilötyt ja kuivatut vihannekset mukaan lukien palkokasvit mutta ei sisällä suolaan tai etikkaan säilöttyjä vihanneksia eikä pähkinöitä, siemeniä tai tärkkelyspitoisia vihanneksia kuten perunaa tai maissia). Diet low in vegetables: Consumption of less than 4 servings (400 g total) of vegetables per day (includes fresh, frozen, cooked, canned, or dried vegetables including legumes but excluding salted or pickled, juices, nuts and seeds, and starchy vegetables such as potatoes or corn).

Luken tilastoista löytyy tietoja kalansyönnistä Suomessa. Järvikalaa ei ole eritelty, mutta muut kuin viljellyt ja merilajit ovat yhteensä 2.6 kg/a henkeä kohti. https://stat.luke.fi/en/fish-consumption-2017_en

Voiko DALYt muuntaa euroiksi, ja miten se tehdään?

Drake ehdottaa globaalin arvon päättämistä DALYn hinnaksi, samaan tapaan kuin 1,25 dollarin alittava päivätulo on määritelty absoluuttiseksi köyhyydeksi. Tällöin kaikki tuota hintaa kustannustehokkaammat toimet kannattaisi tehdä joko kansallisin, tai jos se ei jostain syystä onnistu, kansainvälisin toimin. Hän ei kuitenkaan ehdota suuruutta tälle hinnalle.^[1]
Brent on analysoinut implisiittisiä hintoja DALYlle Global Fund for AIDS, Tuberculosis, and Malaria -säätiön rahoituspäätöksistä. DALYn hinta näyttää olevan 6300 USD kaikille taudeille keskimäärin, ja 11900 USD erityisesti HIV/AIDSille^[2]. Globaalit luvut ovat toki pienemmät kuin mitä rikkaissa länsimaissa katsottaisiin aiheelliseksi käyttää.
Erilaisista arvioinneista löytyy vaihtelevia lukuja yhden DALYn rahalliselle hinnalle. Esimerkiksi IOMin Shecan-projekti käytti arvoa 50393 €/menetetty elinvuosi^[3], ja IGCB(N)-meluarviointiryhmä käyttää arvoa 60000 GBP/QALY (laatupainotettu elinvuosi) mutta samalla toteaa, että eri arvioinneissa arvot voivat vaihdella välillä 29000 - 130000 GBP/QALY^[4]^[5].
Berryn ja Flindellin mukaan Isossa-Britanniassa käytäntö on muodostunut sellaiseksi, että lääkkeet tai muut lääketieteelliset toimenpiteet saavat kansallisessa terveysjärjestelmässä helposti puollon, jos ne tuottavat yhden terveen elinvuoden alle 20000 GBP:n kustannuksilla. Tyypillisesti toteutetaan hankkeita tasolla 30000 GBP/QALY, mutta hankkeilta hinnaltaan yli 50000 GBP/QALY vaaditaan erityisiä perusteluja^[6].
Toisaalta Hammitt todistelee, että hinta per tilastollinen elämä (value per statistical life, VSL) ja hinta per DALY muuttuvat epälineaarisesti suhteessa toisiinsa, eikä näin ollen olisi mahdollista käyttää hyvinvointimuutoksen mittarina vakiolla kerrottua DALY-arvoa, ainakaan taloudellisen hyvinvointiteorian (economic welfare theory) puitteissa.^[7]

Pitoisuusanalyysien kustannukset (poistettu).

Trikiinin valvontakustannukset: Tämän artikkelin mukaan trikiinin DALYt ovat vain luokkaa 100 DALY/miljardi ihmistä, joten valvonta ei ole mielekästä^[8].

Malliparametrit

Malliparametrit(various)
Obs	Response	Exposure_agent	Type	Subgroup	Unit	Result	Description
1	CHD death		BoD	Age:Female 25-69	DALY	9876 (9103 - 10784)	Z:\Projects\RUORI\tautitaakka\Rasvat\IHD_data_IHME.csv
2	CHD death		BoD	Age:Male 25-69	DALY	48851 (54035 - 46123)	Z:\Projects\RUORI\tautitaakka\Rasvat\IHD_data_IHME.csv
3	CHD death		BoD	Age:Age 25-69	DALY	58727 (63138 - 56907)	Summed from previous
4	CHD death		BoD	Age:Female 70+	DALY	42750 (41007 - 45909)	Z:\Projects\RUORI\tautitaakka\Rasvat\IHD_data_IHME.csv
5	CHD death		BoD	Age:Male 70+	DALY	48150 (46327 - 51255)	Z:\Projects\RUORI\tautitaakka\Rasvat\IHD_data_IHME.csv
6	CHD death		BoD	Age:Age 70+	DALY	90900 (87334 - 97164)	Summed from previous
7	Diet high in sodium		BoD	Age:Total population	DALY	1310 : 27670 : 66420	IHME GBD2017. Triangular distribution used because normal would go below zero
8	Diet low in fruits		BoD	Age:Total population	DALY	36050 (20570 - 54800)	IHME GBD2017 http://ghdx.healthdata.org/gbd-results-tool?params=gbd-api-2017-permalink/da3bde44e863adb438c5fb47a89942fb
9	Diet low in vegetables		BoD	Age:Total population	DALY	28440 (14190 - 45960)	IHME GBD2017
10	Liver cancer		BoD	Age:Age 25-64	DALY	2499 (2018 - 3115)	From IHME (2014)
11	Liver cancer		BoD	Age:Age 65-74	DALY	2745 (2245 - 3311)	From IHME (2014)
12	dummy		case burden	Age:Female 25-69	DALY /case	0	Needed for case_burden to cover all Ages
13	dummy		case burden	Age:Female 70+	DALY /case	0	Needed for case_burden to cover all Ages
14	dummy		case burden	Age:Male 25-69	DALY /case	0	Needed for case_burden to cover all Ages
15	dummy		case burden	Age:Male 70+	DALY /case	0	Needed for case_burden to cover all Ages
16	dummy		case burden	Age:Age 25-64	DALY /case	0	Needed for case_burden to cover all Ages
17	dummy		case burden	Age:Age 65-74	DALY /case	0	Needed for case_burden to cover all Ages
18	IQ loss		case burden	Age:Age 1	DALY /IQ	0.11 (0.06 - 0.16)	Arja used 0.013 but here we use Goherr value instead
19	Listeriosis		case burden	Age:Total population	DALY/case	10 (5 - 13.3)	WHO 2015 report, European values (Table A8.2)
20	Noro infection		case burden	Age:Total population	DALY/case	0.0015 - 0.0025	WHO 2015 report, European values (Table A8.2)
21	Toxoplasmosis		case burden	Age:Age 0 (congenital)	DALY/case	7	WHO 2015 report, European values (Table A8.2)
22	Toxoplasmosis		case burden	Age:Age 1+ (acquired)	DALY/case	0.05	WHO 2015 report, European values (Table A8.2)
23	Cancer morbidity		case burden	Age:Female 18-45	DALY/case	0 - 0.28	Goherr assessment
24	Cancer morbidity		case burden	Age:Non female 18-45	DALY/case	0 - 0.28	Goherr assessment
25	Sperm concentration		case burden	Age:Female 18-45	DALY/case	0 - 2.5	Goherr assessment
26	Yes or no dental defect		case burden	Age:Female 18-45	DALY/case	0 - 0.12	Goherr assessment
27		Aflatoxin	exposure	Age:Age 25-64	ng /kg /d	0.85 - 1.14	Finravinto 2012
28		Aflatoxin	exposure	Age:Age 65-74	ng /kg /d	0.5 - 0.67	Finravinto 2012
29		TEQ	exposure	Exposure:To child; Age: Female 18-45	pg /g	1.65 (0.38 - 3.47)	Ruori code; data from Goherr assessment
30		TEQ	exposure	Exposure:To eater; Age: Female 18-45	pg /d	4.79 (1.07 - 11.48)	Ruori code; data from Goherr assessment
31		TEQ	exposure	Exposure:To child; Age: Non female 18-45	pg /g	7.92 (3.25 - 14.61)	Ruori code; data from Goherr assessment
32		TEQ	exposure	Exposure:To eater; Age: Non female 18-45	pg /d	22.61 (9.43 - 44.75)	Ruori code; data from Goherr assessment
33		Lead	exposure	Age:Age 1	ug /l	27.9	Measured as blood concentration. RASKURI, Z:\Projects\RUORI\tautitaakka\Lyijy\Lyijy_tautitaakkadata.xlsx
34		Saturated fat	exposure	Age:Age 25-69	E%	13.1 (12.9 - 13.4)	Finland, 2010 situation from Wang et al. Supplementary
35		Saturated fat	exposure	Age:Age 70+	E%	13.2 (12.8 - 13.6)	Finland, 2010 situation from Wang et al. Supplementary
36		Aflatoxin	frexposed	Age:Age 25-64	fraction	1	dummy variable
37		Aflatoxin	frexposed	Age:Age 65-74	fraction	1	dummy variable
38		Lead	frexposed	Age:Age 1	fraction	0.0657	Population exposed to lead over threshold: 3126. RASKURI, Z:\Projects\RUORI\tautitaakka\Lyijy\Lyijy_tautitaakkadata.xlsx
39		TEQ	frexposed	Age:Female 18-45	fraction	1	frexposed is already in the exposure distribution
40		TEQ	frexposed	Age:Non female 18-45	fraction	1	frexposed is already in the exposure distribution
41	IQ loss		incidence	Age:Age 1	IQ /100000py	596000	On average, a population has ca. 6 IQ points per person below 100: mean(abs(rnorm(10000, 100,15)-100))/2
42	Listeriosis		incidence	Age:Total population	# /100000py	1.22	Tartuntatautirekisteri 2016: 66 kpl. WHO 2015 report, European values (Table A8.2): 0.2 (0.2 - 0.3)
43	Liver cancer		incidence	Age:Age 25-64	# /100000py	4.06	Finnish Cancer Registry, average 2011-2015
44	Liver cancer		incidence	Age:Age 65-74	# /100000py	26.16	Finnish Cancer Registry, average 2011-2015
45	Noro infection		incidence	Age:Total population	# /100000py	1652 (630 - 3294)	WHO 2015 report, European values (Table A8.2)
46	Toxoplasmosis		incidence	Age:Age 0 (congenital)	# /100000py	0.3 (0.2 - 0.7)	WHO 2015 report, European values (Table A8.2)
47	Toxoplasmosis		incidence	Age:Age 1+ (acquired)	# /100000py	119 (77 - 188)	WHO 2015 report, European values (Table A8.2)
48	Cancer morbidity		incidence	Age:Female 18-45	# /100000py	657	Statistics Finland https://tilastot.syoparekisteri.fi/syovat/ applies to all subgroups because cancer is lifetime risk
49	Cancer morbidity		incidence	Age:Non female 18-45	# /100000py	657	Statistics Finland https://tilastot.syoparekisteri.fi/syovat/ applies to all subgroups because cancer is lifetime risk
50	Sperm concentration		incidence	Age:Female 18-45	# /100000py	700	Male infertility rate is 7 % (Wikipedia). 10 % incidence of births
51	Yes or no dental defect		incidence	Age:Female 18-45	# /100000py	2240	Alaluusua et al 2004 found 11/49 cases in two lowest groups. 10 % incidence of births
52	Diet low in fruits	Fruits	PAF	Age:Total population	fraction	1	dummy variable
53	Listeriosis	Listeria	PAF	Age:Total population	fraction	1	dummy variable
54	Noro infection	Noro virus	PAF	Age:Total population	fraction	1	dummy variable
55	CHD death	Saturated fat	PAF	Age:Age 25-69	fraction	0.064 (0.050 - 0.078)	Finland, 2010 situation from Wang et al. Supplementary
56	CHD death	Saturated fat	PAF	Age:Age 70+	fraction	0.048 (0.033 - 0.063)	Finland, 2010 situation from Wang et al. Supplementary
57	Diet high in sodium	Sodium	PAF	Age:Total population	fraction	1	dummy variable
58	Toxoplasmosis	Toxoplasma gondii	PAF	Age:Age 0 (congenital)	fraction	1	dummy variable
59	Toxoplasmosis	Toxoplasma gondii	PAF	Age:Age 1+ (acquired)	fraction	1	dummy variable
60	Diet low in vegetables	Vegetables	PAF	Age:Total population	fraction	1	dummy variable
61			population	Age:Age 1		50934	Statistics Finland, 2018 https://pxnet2.stat.fi:443/PXWeb/sq/ac3373d0-e303-4c67-b32a-73c6d26df809
62			population	Age:Age 25-64	#	2814305	Statistics Finland
63			population	Age:Age 65-74	#	692868	Statistics Finland
64			population	Age:Age 25-69	#	3176513	Statistics Finland
65			population	Age:Age 70+	#	842629	Statistics Finland
66			population	Age:Total population	#	5517919	Statistics Finland
67			population	Age:Age 0 (congenital)	#	47663	Statistics Finland
68			population	Age:Age 1+ (acquired)	#	5470256	Statistics Finland
69			population	Age:Female 18-45	#	923697	Statistics Finland
70			population	Age:Non female 18-45	#	4594222	Statistics Finland
71	Hepatitis		prevalence	Hepatitis:Hepatitis B-	fraction	0.005	TerveSuomi
72	Hepatitis		prevalence	Hepatitis:Hepatitis B+	fraction	0.995	TerveSuomi
73		Saturated fat	scenario exposure	Age:Male 18-24	E%	14.9	Finravinto 2017. Supplementary table 7.12. Average daily intake of saturated fats by gender and age.
74		Saturated fat	scenario exposure	Age:Male 25-44	E%	15.2	Finravinto 2017. Supplementary table 7.12. Average daily intake of saturated fats by gender and age.
75		Saturated fat	scenario exposure	Age:Male 45-64	E%	15.3	Finravinto 2017. Supplementary table 7.12. Average daily intake of saturated fats by gender and age.
76		Saturated fat	scenario exposure	Age:Male 65-74	E%	14.4	Finravinto 2017. Supplementary table 7.12. Average daily intake of saturated fats by gender and age.
77		Saturated fat	scenario exposure	Age:Female 18-24	E%	13.8	Finravinto 2017. Supplementary table 7.12. Average daily intake of saturated fats by gender and age.
78		Saturated fat	scenario exposure	Age:Female 25-44	E%	14.8	Finravinto 2017. Supplementary table 7.12. Average daily intake of saturated fats by gender and age.
79		Saturated fat	scenario exposure	Age:Female 45-64	E%	14.3	Finravinto 2017. Supplementary table 7.12. Average daily intake of saturated fats by gender and age.
80		Saturated fat	scenario exposure	Age:Female 65-74	E%	14.0	Finravinto 2017. Supplementary table 7.12. Average daily intake of saturated fats by gender and age.
81	IQ loss	Lead	threshold	Age:Age 1	ug /l	24	Lanphear et al 2005 https://doi.org/10.1289/ehp.7688 CHECK THRESHOLD
82	Liver cancer	Aflatoxin	UR	Hepatitis:Hepatitis B-	# /(ng /kg /d /100000py)	0.01 (0.002 - 0.03)	WHO Is this per year or per lifetime?
83	Liver cancer	Aflatoxin	UR	Hepatitis:Hepatitis B+	# /(ng /kg /d /100000py)	0.3 (0.01 - 0.5)	WHO Is this per year or per lifetime?
84	IQ loss	Lead	UR	Age:Age 1	IQ l /ug	0.039	Lanphear et al 2005 https://doi.org/10.1289/ehp.7688 CHECK THRESHOLD
85		Sodium	reduction	Age:Total population	g /d	0.471 - 0.729	RUORI estimates 3.3-5.1 g/week reduction for workplace lunches with heart-friendly label
86		Sodium	intake	Age:Total population	g /d	6.4 - 8.7	Valsta 2018 estimated the lower value for females and upper for males.
87		Sodium	recommendation	Age:Total population	g /d	5	Finnish recommendation by Ruokavirasto
88		Sodium	eaters	Age:Total population	#	279000	RUORI estimate based on Taloustutkimus 2010
89		Saturated fat	reduction	Age:Age 25-69	E%	1.397 - 3.689	RUORI estimates 22.0 - 58.1 g /week, and on average 2.25 g /d /E%
90		Saturated fat	intake	Age:Age 25-69	E%	14 - 15	Valsta 2018 estimated the lower value for females and upper for males.
91		Saturated fat	recommendation	Age:Age 25-69	E%	10	Recommendation by Ruokavirasto?
92		Saturated fat	eaters	Age:Age 25-69	#	279000	RUORI estimate based on Taloustutkimus 2010
93		Vegetables	reduction	Age:Total population	g /d	-30 - 0	RUORI estimates that the consumption increases by 0-14% (up to the % change of tax reduction) i.e. 0.14*213.
94		Vegetables	intake	Age:Total population	g /d	196 - 213	Valsta 2018 estimated the lower value for males and upper for females. (vegetables, legumes, nuts)
95		Vegetables	recommendation	Age:Total population	g /d	400	Recommendation by IHME
96		Vegetables	eaters	Age:Total population	#	5470256	RUORI estimate based on Taloustutkimus 2010
97		Fruits	reduction	Age:Total population	g /d	-26 - 0	RUORI estimates that the consumption increases by 0-14% (up to the % change of tax reduction) i.e. 0.14*189.
98		Fruits	intake	Age:Total population	g /d	135 - 189	Valsta 2018 estimated the lower value for males and upper for females. (fruits and berries)
99		Fruits	recommendation	Age:Total population	g /d	310	Recommendation by IHME
100		Fruits	eaters	Age:Total population	#	5470256	RUORI estimate based on Taloustutkimus 2010

Annos-vasteet on tässä vain näytillä, ja oikeat käyttöön tulevat luvut ovat sivulla op_en:ERFs of environmental pollutants.

Decisions(-)
Obs	Decision	Option	Variable	Cell	Change	Result	Description
1	Adjust	BAU	incidence		Multiply	0.00001	1/100000 py --> 1 py
2	Adjust	BAU	PAF	Exposure_agent:Saturated fat	Multiply	1.132	Scaled from Wang to Finravinto 2017: mean(15.2,15.3,14.8,14.0)/13.1
3	Hepatitis	Hepatitis B-	BoD		Multiply	0.995	Healthy people. Data from TerveSuomi
4	Hepatitis	Hepatitis B+	BoD		Multiply	0.005	Hepatitis B patients. Data from TerveSuomi
5	Adjust	BAU	ERF	Response:Liver cancer	Multiply	0.00001	1/100000py --> 1/py
6	Scenario	Action	PAF	Exposure_agent:Saturated fat	Multiply	0.911 : 0.944 : 0.971	Based on RUORI modelling (see code)
7	Scenario	Action	PAF	Exposure_agent:Sodium	Multiply	0.975 : 0.990 : 0.993	Based on RUORI modelling (see code)
8	Scenario	BAU	PAF		Identity		For completion
9	Scenario	Action	PAF	Response:Toxoplasmosis;Age:Age 0 (congenital)	Multiply	0	Complete testing and treatment of gongenital disease
10	Scenario	Action	PAF	Response:Listeriosis	Multiply	0	Complete testing and removal of pathogen
11	Scenario	Action	exposure	Exposure_agent:Aflatoxin	Multiply	0.95-1	0-5% reduction of exposure based on 10 % more testing
12	Scenario	Action	exposure	Exposure_agent:Lead	Multiply	0.963-0.975	2.5-3.7% reduction of exposure based on more testing
13	Scenario	BAU	exposure		Identity		For completion
14	Scenario	Action	PAF	Exposure_agent:Noro virus	Multiply	0.65 : 1 : 1	35 % are from food industry so that is the max reduction from testing
15	Scenario	Action	PAF	Exposure_agent:Vegetables	Multiply	0.85 - 1	Based on RUORI modelling (see code)
16	Scenario	Action	PAF	Exposure_agent:Fruits	Multiply	0.82 - 1	Based on RUORI modelling (see code)
17	Adjust	BAU	exposure		Add	0.01	Roughly 98 % of all exposures for Exposure_agents is > 0.005. This prevents NaN in log scaling.
18	Scenario	Action	exposure	Exposure: To child; Age: Female 18-45	Replace	0.98 (0.17 - 2.9)	Based on RUORI modelling (see code)
19	Scenario	Action	exposure	Exposure: To eater; Age: Female 18-45	Replace	2.79 (0.56 - 7.08)	Based on RUORI modelling (see code)
20	Scenario	Action	exposure	Exposure: To child; Age: Non female 18-45	Replace	3.68 (1.16 - 11.27)	Based on RUORI modelling (see code)
21	Scenario	Action	exposure	Exposure: To eater; Age: Non female 18-45	Replace	11.38 (3.44 - 46.22)	Based on RUORI modelling (see code)

CollapseMarginals(-)
Obs	Variable	Index	Probs	Function	Dummy	Description
1	BoD	incidenceSource,disabilityweightSource,populationSource,BoDSource		sum	1	Remove redundant
2	PAF	Unit, Exposure, Scaling,Exposcen, ER_function, ERFchoiceSource, exposureSource, bgexposureSource, BWSource, doseSource, thresholdSource, ERFSource, RRSource, frexposedSource, incidenceSource, InpPAFSource		sum	1	Remove redundant
3	case_burden	case_burdenSource		sum	1	Fill missing Ages
4	BoDattr	PAFSource, Hepatitis, Adjust		sum	1	Remove redundant
5	amount	assumpSource, oftenSource, muchSource, oftensideSource, muchsideSource, amountRawSource, effinfoSource, effrecommSource, amountSource		sum	1	Remove redundant
6	expo_indir	f_ingSource, t0.5Source,f_mtocSource, BFSource		sum	1	Remove redundant
7	dose	Source, concSource, expo_dirSrouce, exposureSource, BWSource, Source.1		sum	1	Remove redundant
8	conc	Fish	0, 1, 0, 0, 0, 0, 0.19, 0.19, 0.19, 0, 0, 0, 0, 0, 0, 0, 0.29, 0.14	sample	1	Probs relative to consumption; Baltic herring has equal weight with others combined because it is another scenario. Arctic char, Baltic herring, Bream, Burbot, Cod, Flounder, Perch, Pike, Pike-perch, Rainbow trout, River lamprey, Roach, Salmon, Sea trout, Sprat, Trout, Vendace, Whitefish
9	ERF	Exposure, Age		sum	1	Remove redundant
10	threshold	Exposure, Age		sum	1	Remove redundant

Laskenta

Arviointimalli

Skenaariot

Tyydyttyneen rasvan ja suolan osalta tarkastellaan sydänmerkkiaterioita. Oletetaan, että kaikki lounasruokaloiden ateriat muuttuvat sydänmerkkiaterioiksi. Väestön suuruudeksi oletetaan nykyinen lounaspaikkaruokailijoiden päivittäinen määrä eli 279000, ja heille oletetaan pysyvä muutos ruokavalioon.

Kun ei murehdita altistusjakaumasta, voidaan keskimääräisestä saannista vähentää vähennys, ja tämä muutos kohdennetaan vain 25-69-vuotiaaseen alaryhmään (jos alaryhmä on kyseiselle vasteelle määritelty). Skenaariossa kerrotaan PAF luvulla, joka saa arvon 1 nykyisellä altistuksella ja arvon 0 suosituksen mukaisella arvolla. Tätäitä laimennetaan altistujien osuudella. Niinpä käytetään tätä kaavaa kertoimen laskemiseksi:

PAF_factor = 1-(reduction / (intake-recommendation)) * eaters / population

Suola:

Sydänmerkki vähensi 2016 suolan saantia 1 g/d eli 4.2-5.2 g/vk eli 10 %. Tässä oletetaan 3.3-5.1 g/vk vähennys eli 0.471 - 0.729 g/d myös viikoloput huomioiden. Jula (2011) arvioi, että 1 g/d vähennys koko väestössä alentaa kustannuksia 70 Me/a. (Tarkista onko tautitaakkaa!)

Suositus on enintään 5 g/d. Nykysaanti (Valsta 2018) on miehillä 8.7 g/d ja naisilla 6.4 g/d ja tätä käytetään tasajakaumana koko väestölle, koska sukupuolia ei tarkastella erikseen.

Rasva:

Sydänmerkkiateria vähensi saantia 14 E%:sta 10 E%:iin. Tässä oletetaan, että vähennys on 22.0-58.1 g/vk.

Suositus on enintään 10 E%.

Valsta (2018): Tyydyttyneiden rasvahappojen osuus kokonaisenergiasta oli naisilla 14 % (28 g/vrk) ja miehillä 15 % (38 g/vrk). Naisilla muuntosuhde on 2 g /d /E% ja miehillä 2.53 g /d /E%, käytetään 2.25 g /d /E%. Grammamääräinen altistus on muutettava energiaosuudeksi.

22.0-58.1 g/vk / (7d/vk) / (2.25 g /d /E%) = 1.397 - 3.689 E%

Näiden tietojen avulla lasketaan PAF-kertoimen jakauma, joka sijoitetaan päätöstauluun päätöksenä Scenario ja vaihtoehtona Action.

Malliajo 29.5.2019 [3]
Malliajo 31.5.2019 [4]
Malliajo 4.6.2019, ovariablet haetaan ao. sivuilta ja OpasnetUtilsista on päivitetty versio (ei toimi vanhalla) [5]
Malliajo 12.6.2017 jossa suolan ja rasvan skenaario [6]
Malliajo 12.6. myös muita skenaarioita [7]
Malliajo 13.6.2019 skenaariot dioksiinia lukuunottamatta [8]
Malliajo 16.6.2019 melkein toimii [9]

[10]

[11]

+ Näytä koodi - Piilota koodi

# This is code Op_fi5889/ on page [[Ruori]]
library(OpasnetUtils)
library(ggplot2)
#library(thlVerse)

# First remove all objects for a fresh start. Otherwise may be problems with CheckDecisions.
rm(list=ls())
rm(list=ls(envir=openv),envir=openv)

openv.setN(1000)

dat <- opbase.data("Op_fi5889", subset="Malliparametrit")[-1]

dec <- opbase.data("Op_fi5889", subset="Decisions")[-1]
DecisionTableParser(dec)

CTable <- opbase.data("Op_fi5889",subset="CollapseMarginals")
for(i in 1:ncol(CTable)) {CTable[[i]] <- as.character(CTable[[i]])}
CollapseTableParser(CTable)

cat("Laskennassa käytetty data.\n")
oprint(dat)
cat("Tarkastellut päätökset.\n")
oprint(dec)
cat("Aggregoidut marginaalit.\n")
oprint(CTable)

#' prepare adjusts the data table for ovariables. Requires function subgrouping from code Op_en2031/initiate on page [[Exposure-response function]]
#' @param dat data.frame
#' @param type type of data that is used. Must match content in column Type
#' @param drop columns to remove
#' @return data.frame

prepare <- function(dat, type=NULL, drop=NULL) {
  out <- dat
  if(!is.null(type)) out <- out[out$Type %in% type , ]
  if(!is.null(drop)) out <- out[!colnames(out) %in% drop]
  return(subgrouping(out))
}

objects.latest("Op_en2031", code_name="initiate") # [[Exposure-response function]] subgrouping

population <- Ovariable("population", data = prepare(dat,"population",c("Type","Exposure_agent","Response","Unit")))

exposure <- Ovariable("exposure", data = prepare(dat, "exposure", c("Type","Response")))

frexposed <- Ovariable("frexposed", data=prepare(dat, "frexposed", c("Type","Response","Unit")))

incidence <- Ovariable("incidence", data = prepare(dat,"incidence",c("Type","Exposure_agent","Unit")))

reduction <- Ovariable("reduction", data = prepare(dat,"reduction",c("Type","Response")))

intake <- Ovariable("intake", data = prepare(dat,"intake",c("Type","Response")))

recommendation <- Ovariable("recommendation", data = prepare(dat,"recommendation",c("Type","Response")))

eaters <- Ovariable("eaters", data = prepare(dat,"eaters",c("Type","Response","Unit")))

ERFChoice <- Ovariable(
  "ERFchoice",
  data=data.frame(
    Response=c("IQ loss","Liver cancer","Yes or no dental defect","Cancer morbidity","Sperm concenctration"),
    Exposure_agent=c("Lead","Aflatoxin","TEQ","TEQ","TEQ"),
    Result=1)
)

###### This is temporary code that is used to calculate the option "Action" of decision "Scenario".

if(FALSE) {
  PAF_factor <- Ovariable(
    "PAF_factor",
    dependencies=data.frame(Name=c("reduction","intake","recommendation","eaters","population")),
    formula = function(...) {
      out <- 1 - reduction / (intake - recommendation) * eaters / population
      return(out)
    }
  )
  
  PAF_factor <- EvalOutput(PAF_factor) 
  
  ggplot(PAF_factor@output, aes(x=PAF_factorResult, fill=Exposure_agent))+geom_density()+facet_wrap(~Exposure_agent)
  
  summary(PAF_factor)
  
  # The PAF_factor distributions for saturated fat and sodium are NOT normally distributed. Instead, triangular
  # distribution seems to be a reasonable fit with parameters:
  # Sodium: triangular 0.975 : 0.990 : 0.993
  # Saturated fat: triangular 0.911 : 0.944 : 0.971
}
######### End of temporary code

# case_burden equals disabilityweight * duration
# DO WE NEED GOHERR VALUES? COPY THE IMPORTANT PARTS TO RUORI

#case_burden <- Ovariable(
#  "case_burden",
#  ddata = "Op_en7748", # [[Goherr assessment]]
#  subset = "DALYs of responses"
#)
#colnames(case_burden@data)[match(
#  c("Resp","case_burdenResult"),
#  colnames(case_burden@data))] <- c("Response","Result")

case_burden <- Ovariable("case_burden", data= prepare(dat,"case burden",c("Type","Exposure_agent","Unit")))

InpPAF <- EvalOutput(Ovariable("InpPAF", data =  prepare(dat,"PAF","Type")))

InpBoD <- EvalOutput(Ovariable("InpBoD", data = prepare(dat, "BoD", c("Type","Exposure_agent"))))

objects.latest("Op_en2261",code_name="BoDattr") # [[Health impact assessment]]

BoDattr <- EvalOutput(BoDattr)

levels(BoDattr$Exposure_agent)
#[1] "Aflatoxin"         "Lead"     "TEQ"         "Fruits"            "Listeria"          "Noro virus"        "Saturated fat"     "Sodium"           
#[8] "Toxoplasma gondii" "Vegetables"       

levels(BoDattr$Exposure_agent) <- c("Aflatoksiini","Lyijy", "Dioksiini", "Hedelmävaje","Listeria","Norovirus",
                                    "Tyydyttynyt rasva","Suola", "Toksoplasma","Vihannesvaje")

lev <- oapply(BoDattr[BoDattr$Scenario=="BAU",],"Exposure_agent",sum)@output
lev <- lev$Exposure_agent[order(lev$BoDattrResult)]
BoDattr$Exposure_agent <- factor(BoDattr$Exposure_agent, levels=lev)

utility <- Ovariable(
  "utility",
  dependencies = data.frame(Name="BoDattr"),
  formula = function(...) {
    out <- BoDattr * Ovariable(data=data.frame(Scenario=c("Action","BAU"),Result=c(1,-1)))
    out <- oapply(out, cols=c("Scenario","Response","Age"),FUN=sum)
    return(out)
  }
)

utility <- EvalOutput(utility)

cat("exposure\n")
oprint(summary(exposure,marginals=c("Exposure_agent","Age","Scenario")),digits=7)
oprint(exposure@output[exposure$Iter==1,])
cat("dose\n")
oprint(summary(dose),digits=7)
cat("ERF\n")
oprint(ERF@output[ERF$Iter==1,],digits=7)
cat("incidence\n")
oprint(summary(incidence),digits=7)
cat("frexposed\n")
oprint(summary(frexposed),digits=7)
cat("PAF\n")
oprint(summary(PAF),digits=7)
cat("BoD\n")
oprint(summary(BoD),digits=7)
cat("BoDattr\n")
oprint(summary(BoDattr,marginals=c("Response","Exposure_agent","Scenario","Age")),digits=7)
cat("Vähennyspotentiaali\n")
tmp <- summary(utility, marginals=c("Response","Exposure_agent"))
oprint(tmp[order(unlist(tmp$mean)),])

##################

thlBarPlot <- function (data, xvar, yvar, groupvar = NULL, ylabel = yvar, xlabel = NULL, 
    colors = thlColors(n = 5, type = "quali", name = "bar"), 
    title = NULL, subtitle = NULL, caption = NULL, legend.position = "none", 
    base.size = 16, show.grid.x = FALSE, show.grid.y = TRUE, 
    lang = "fi", ylimits = NULL, xaxis.breaks = waiver(), xaxis.labels = waiver(), 
    yaxis.breaks = waiver(), panels = FALSE, nrow.panels = 1, 
    barwd = 0.7, show.value = FALSE, value.box = FALSE, value.digits = NULL, 
    value.size = thlPtsConvert(9), value.vjust = 0.9, value.hjust = 0.5, 
    horizontal = FALSE, stacked = TRUE, yaxis = TRUE, xaxis = TRUE) 
{
    if (.Platform$OS.type == "windows") {
        windowsFonts(Arial = windowsFont("Arial Unicode MS"))
    }
    if (stacked) {
        bar.position = position_stack(reverse = TRUE)
        value.position = position_stack(vjust = value.vjust, 
            reverse = TRUE)
        if (horizontal) {
            value.vjust = 0.5
        }
    }
    else {
        bar.position = position_dodge2(width = 0.9, preserve = "single", 
            padding = 0)
        value.position = position_dodge(width = 0.7)
        if (horizontal) {
            value.vjust = 0.4
            value.hjust = 1.1
        }
        else {
            value.vjust = 1.1
        }
    }
    gg <- ggplot(data, aes_(x = substitute(factor(xvar)), y = substitute(yvar), 
        group = ifelse(!is.null(substitute(groupvar)), substitute(groupvar), 
            NA), fill = ifelse(!is.null(substitute(groupvar)), 
            substitute(groupvar), ""))) + geom_bar(stat = "identity", 
        colour = "white", size = 1.05, width = barwd, position = bar.position) + 
        {
            if ((!horizontal & stacked)) {
                guides(fill = guide_legend(reverse = TRUE))
            }
        } + {
        if (horizontal & stacked) {
            guides(fill = guide_legend(reverse = FALSE))
        }
    } + {
        if (horizontal & !stacked) {
            guides(fill = guide_legend(reverse = TRUE))
        }
    } + {
        if (horizontal) {
            coord_flip()
        }
    }
    gg <- gg + ylab(ifelse(deparse(substitute(ylabel)) == "yvar", 
        deparse(substitute(yvar)), ylabel)) + labs(title = ifelse(!is.null(substitute(title)), 
        substitute(title), ""), subtitle = subtitle, caption = caption) + 
        thlTheme(show.grid.y = show.grid.y, show.grid.x = show.grid.x, 
            base.size = base.size, legend.position = legend.position, 
            horizontal = horizontal, x.axis.title = ifelse(!is.null(xlabel), 
                TRUE, FALSE)) + xlab(ifelse(!is.null(xlabel), 
        xlabel, "")) + thlYaxisControl(lang = lang, limits = ylimits, 
        breaks = yaxis.breaks, sec.axis.breaks = brks, sec.axis.labels = labsut) + 
        scale_x_discrete(breaks = xaxis.breaks, labels = xaxis.labels) + 
        scale_fill_manual(values = colors)
    if (isTRUE(panels)) {
        fmla <- as.formula(paste0("~", substitute(groupvar)))
        gg <- gg + facet_wrap(fmla, scales = "free", nrow = nrow.panels)
    }
    if (isTRUE(show.value & value.box)) {
        if (isTRUE(is.null(value.digits))) {
            gg <- gg + geom_label(aes_(group = ifelse(!is.null(substitute(groupvar)), 
                substitute(groupvar), ""), label = substitute(format(yvar, 
                big.mark = ifelse(lang == "fi", " ", ","), decimal.mark = ifelse(lang == 
                  "fi", ",", ".")))), fill = "white", size = 0.9 * 
                value.size, show.legend = FALSE, position = value.position, 
                colour = "#606060", vjust = value.vjust, hjust = value.hjust)
        }
        else {
            gg <- gg + geom_label(aes_(group = ifelse(!is.null(substitute(groupvar)), 
                substitute(groupvar), ""), label = substitute(format(round(yvar, 
                value.digits), big.mark = ifelse(lang == "fi", 
                " ", ","), decimal.mark = ifelse(lang == "fi", 
                ",", ".")))), fill = "white", size = 0.9 * value.size, 
                show.legend = FALSE, position = value.position, 
                colour = "#606060", vjust = value.vjust, hjust = value.hjust)
        }
    }
    else if (isTRUE(show.value)) {
        if (isTRUE(is.null(value.digits))) {
            gg <- gg + geom_text(aes_(group = ifelse(!is.null(substitute(groupvar)), 
                substitute(groupvar), ""), label = substitute(format(yvar, 
                big.mark = ifelse(lang == "fi", " ", ","), decimal.mark = ifelse(lang == 
                  "fi", ",", ".")))), size = value.size, show.legend = FALSE, 
                position = value.position, colour = "white", 
                fontface = "bold", vjust = value.vjust, hjust = value.hjust)
        }
        else {
            gg <- gg + geom_text(aes_(group = ifelse(!is.null(substitute(groupvar)), 
                substitute(groupvar), ""), label = substitute(format(round(yvar, 
                value.digits), big.mark = ifelse(lang == "fi", 
                " ", ","), decimal.mark = ifelse(lang == "fi", 
                ",", ".")))), size = value.size, show.legend = FALSE, 
                position = value.position, colour = "white", 
                fontface = "bold", vjust = value.vjust, hjust = value.hjust)
        }
    }
    if (!xaxis) {
        if (!horizontal) {
            gg <- gg + theme(axis.line.x = element_blank())
        }
        else {
            gg <- gg + theme(axis.line.y = element_blank())
        }
    }
    if (!yaxis) {
        if (!horizontal) {
            gg <- gg + theme(axis.text.y = element_blank()) + 
                ylab("")
        }
        else {
            gg <- gg + theme(axis.text.x = element_blank()) + 
                ylab("")
        }
    }
    gg
}
###################
# Disease burden

dodge <- position_dodge(width=0.7)

thlBarPlot(summary(oapply(BoDattr[BoDattr$Scenario=="BAU",],NULL,sum,"Age")),
           xvar=Exposure_agent, yvar=unlist(mean), groupvar=Response, legend.position="bottom",
           colors=thlColors(n=12),
           title="Elintarvikkeiden tautitaakkoja Suomessa", subtitle="Haittapainotettua elinvuotta vuodessa (DALY/a)")+coord_flip()

thlBarPlot(summary(oapply(BoDattr, NULL, sum,c("Age","Response"))),xvar=Exposure_agent, yvar=unlist(mean),
           groupvar=Scenario,stacked=FALSE,
           title="Elintarvikkeiden tautitaakkoja Suomessa",
           subtitle="Haittapainotettua elinvuotta vuodessa (DALY/a)")+coord_flip()+
  geom_errorbar(aes(ymin=unlist(Q0.025),ymax=unlist(Q0.975),group=Scenario),position=dodge, width=0.3)

#ggsave("Ruori-tautitaakat.png",width=10,height=6)

# Utility of actions

thlBarPlot(summary(utility),xvar=Exposure_agent, yvar=unlist(mean),
           title="Skenaarioiden vaikutus tautitaakkaan",
           subtitle="Haittapainotettua elinvuotta vuodessa (DALY/a)")+coord_flip()+
  geom_errorbar(aes(ymin=unlist(Q0.025),ymax=unlist(Q0.975)),position=dodge, width=0.3)

#ggsave("Ruori-toimenpideiden vaikutus.png",width=10,height=6)

Dioksiiniskenaario

Malliajo 13.6.2019 [12]
Malliajo 14.6.2019 [13] [14]

[15]

Malliajo 16.6.2019 [16]
Malliajo 17.6.2019 ja lopulta näyttäisi toimivan [17]

+ Näytä koodi - Piilota koodi

# This is code Op_fi5889/prepare on page [[Ruori]]

library(OpasnetUtils)
library(ggplot2)

rm(list=ls())
rm(list=ls(envir = openv),envir=openv)

openv.setN(10000)

##############################

# Population data

if(FALSE) {
  # Read population data 2018 from Statistics Finland
  #vae <- re#ad.csv("https://pxnet2.stat.fi:443/PXWeb/sq/ac3373d0-e303-4c67-b32a-73c6d26df809", skip=2)
  #vae$Ikä <- as.numeric(gsub(" -","",as.character(vae$Ikä)))
  
  cat("Ages 1, 25-64, 65-74, 25-29, 70+, Total population, 0, 1+, Female 18-45, Non female 18-45\n")
  c(
    sum(vae$X2018[vae$Ikä==1]), # Age 1
    sum(vae$X2018[vae$Ikä>=25 & vae$Ikä <65]), # Age 25-64
    sum(vae$X2018[vae$Ikä>=65 & vae$Ikä <75]), # Age 65-74
    sum(vae$X2018[vae$Ikä>=25 & vae$Ikä <70]), # Age 25-69
    sum(vae$X2018[vae$Ikä>=70 & vae$Ikä <101]), # Age 70+
    sum(vae$X2018), # Total population
    sum(vae$X2018[vae$Ikä==0]), # Age 0
    sum(vae$X2018[vae$Ikä>=1]), # Age 1+
    sum(vae$X2018[vae$Ikä>=18 & vae$Ikä <46 & vae$Sukupuoli=="Naiset"]), #Female 18-45
    sum(vae$X2018[!(vae$Ikä>=18 & vae$Ikä <46 & vae$Sukupuoli=="Naiset")]) #Non female 18-45
  )
}

##########################3

dat <- opbase.data("Op_fi5889", subset="Malliparametrit")[-1]

dec <- opbase.data("Op_fi5889", subset="Decisions")[-1]
DecisionTableParser(dec)

CTable <- opbase.data("Op_fi5889",subset="CollapseMarginals")
for(i in 1:ncol(CTable)) {CTable[[i]] <- as.character(CTable[[i]])}
CollapseTableParser(CTable)

cat("Laskennassa käytetty data.\n")
oprint(dat)
cat("Tarkastellut päätökset.\n")
oprint(dec)
cat("Aggregoidut marginaalit.\n")
oprint(CTable)

#' prepare adjusts the data table for ovariables. Requires function subgrouping from code Op_en2031/initiate on page [[Exposure-response function]]
#' @param dat data.frame
#' @param type type of data that is used. Must match content in column Type
#' @param drop columns to remove
#' @return data.frame

prepare <- function(dat, type=NULL, drop=NULL) {
  out <- dat
  if(!is.null(type)) out <- out[out$Type %in% type , ]
  if(!is.null(drop)) out <- out[!colnames(out) %in% drop]
  return(subgrouping(out))
}

objects.latest("Op_en2031", code_name="initiate") # [[Exposure-response function]] subgrouping

###### Concentration data

objects.latest("Op_en3104", code_name="preprocess") # [[EU-kalat]]") eu2

# Get a lognormal concentration distribution for each fish species using same sd and individual means

conc <- Ovariable(
  "conc",
  dependencies=data.frame(Name=c("eu2")),
  formula = function(...) {
    out <- (oapply(eu2[eu2$Compound %in% c("PCDDF", "PCB") , ], NULL, sum, "Compound"))
    out <- oapply(log(out), c("Fish","eu2Source"), mean)
    result(out) <- paste(result(out), oapply(out, c("eu2Source"), sd)$eu2Result, sep="+-")
    out <- out@output[colnames(out@output)!="eu2Source"]
    colnames(out)[colnames(out)=="eu2Result"] <- "Result"
    out$Exposure_agent <- "TEQ"
    out <- exp(EvalOutput(Ovariable("conc",data=out)))
    out$Scenario <- ifelse(out$Fish=="Baltic herring", "BAU","Action")
    return(out)
  }
)

######## Fish intake data

objects.latest("Op_en7749", code_name = "initiate") # [[Goherr: Fish consumption study]]
## Variables assump, often, much, oftenside, muchside, amountRaw, effinfo, effrecomm, amount

effinfo <- 0 # We are not interested in changes in amount
effrecomm <- 0

amountOrigFormula <- amount@formula
amount@formula <- function(...) {
  out <- amountOrigFormula(...)
  out <- oapply(out[out$Fish=="Herring",], NULL, sum, "Fish")
  out <- out * info
  return(out)
}

# Stores non-marginal columns for further use.
info <- Ovariable(
  "info",
  dependencies = data.frame(Name = c("jsp")),
  formula = function(...) {
    out <- unique(jsp@output[c("Iter","Country","Gender","Ages","Row")])
    out <- out[out$Country=="FI",]
    out$Group <- paste(out$Gender, out$Ages)
    out$Group <- ifelse(out$Group=="Female 18-45", out$Group, "Non female 18-45")
    out$Result <- 1
    return(out)
  }
)

expo_bg <- 0

expo_dir <- Ovariable(
  "expo_dir",
  dependencies=data.frame(Name=c("amount","conc","expo_bg")),
  formula = function(...) {
    out <- amount * conc
    
    out <- Ovariable(data = data.frame(
      Exposcen = c("BAU", "No exposure"),
      Result = c(1, 0)
    )) * out + expo_bg
    out$Exposure <- as.factor(
      ifelse(
        out$Exposure_agent %in% c("DHA", "MeHg"),
        "To child",
        "To eater"
      )
    )
    out@marginal[colnames(out@output)=="Exposcen"]<- TRUE
    return(out)
  }
)

### mc2d makes a 2D Monte Carlo with assumed 50 individuals in data. Exposure is their average.

exposure <- Ovariable(
  "exposure",
  dependencies = data.frame(
    Name = c(
      "expo_dir", # direct exposure, i.e. the person eats or breaths the exposure agent themself
      "expo_indir", # indirect exposure, i.e. the person (typically fetus or infant) is exposed via someone else (mother)
      "mc2d" # 2D Monte Carlo function
    ),
    Ident = c(
      NA,
      "Op_en7797/expo_indir", # [[Infant's dioxin exposure]] # expo_indir
      "Op_en7805/mc2d") # [[Two-dimensional Monte Carlo]]
  ),
  formula = function(...) {
    out <- combine(expo_dir, expo_indir)
    out <- unkeep(out, "Source.1", sources=TRUE)
    out <- mc2d(out)
    return(out)
  }
)
exposure@meta <- c(
  exposure@meta, 
  list(units = "To eater: pg /day; to child: pg /g fat")
)

mc2dparam<- list(
  N2 = 1000, # Number of iterations in the new Iter
  strength = 50, # Sample size to which the fun is to be applied. Resembles number of observations
  run2d = TRUE, # Should the mc2d function be used or not?
  info = info, # Ovariable that contains additional indices, e.g. newmarginals.
  newmarginals = c("Group","Exposure"), # Names of columns that are non-marginals but should be sampled enough to become marginals
  method = "bootstrap", # which method to use for 2D Monte Carlo? Currently bootsrap is the only option.
  fun = mean # Function for aggregating the first Iter dimension.
)

exposure <- EvalOutput(exposure,verbose=TRUE)

oprint(summary(exposure[exposure$Exposcen=="BAU",], marginals=c("Exposure_agent","Scenario","Group","Exposure")))
oprint(summary(conc))
oprint(summary(amount*info,marginals="Group"))

ggplot(conc@output, aes(x=concResult, colour=Scenario))+stat_ecdf()+scale_x_log10()

ggplot((info*amount)@output, aes(x=amountResult+0.01, colour=Group))+stat_ecdf()+scale_x_log10()

ggplot(expo_indir@output, aes(x=expo_indirResult+0.01, colour=Group))+stat_ecdf()+scale_x_log10()+facet_grid(Group~Exposure)

ggplot(exposure@output[exposure$Exposcen=="BAU",], aes(x=exposureResult, colour=Scenario))+geom_density()+facet_grid(Group~Exposure)

tmp <- summary(exposure[exposure$Exposcen=="BAU",], marginals=c("Scenario","Group","Exposure"))
tmp[4:10] <- as.data.frame(lapply(tmp[4:10], function(x) round(x, 2)))
tmp$out <- paste0(tmp$mean, " (",tmp$Q0.025, " - ", tmp$Q0.975, ")")
oprint(tmp)
tmp$out

##############################

# Domestic fish consumption. Used to give weights to fish species concentration data

tmp <- opbase.data("Op_en7749", subset="Fish consumption as food in Finland")
tmp <- tmp[tmp$Origin=="domestic fish" & !tmp$Species %in% c(
  "Total", "Farmed rainbow trout","Baltic herring", "Other domestic fish") & tmp$Year==2017 , 
  !colnames(tmp) %in% c("Obs","Origin", "Year")]
colnames(tmp)[colnames(tmp)=="Species"] <- "Fish"
levels(tmp$Fish)[
  match(c("European whitefish", "Pike perch"), levels(tmp$Fish))] <- c("Whitefish","Pike-perch")
tmp$Result <- tmp$Result / sum(tmp$Result)
tmp <- merge(unique(eu2@output["Fish"]), tmp, all.x=TRUE)
tmp$Result[is.na(tmp$Result)] <- 0
tmp$Result[tmp$Fish=="Baltic herring"] <- 1 # Baltic herring is on BAU scenario and gets equal weight with others combined

cat("Copy these weights to CollapseMarginal table for conc Collapsing.\n")
round(tmp$Result,2)

##### Q25 was used when 25 quantiles were estimated. Now we use rnorm estimate.
Q25 <- function(x) {
  return(round(quantile(x, probs = seq(0.02, 0.98, 0.04)),1))
}

summary(exposure[exposure$Exposcen=="BAU",], marginals=c("Exposure","Group","Scenario"), "Q25")

################ Insight network

gr <- scrape(type="assessment")
objects.latest("Op_en3861", "makeGraph") # [[Insight network]]
gr <- makeGraph(gr)
#export_graph(gr, "ruori.svg")
render_graph(gr)

Tautitaakkakuvia

+ Näytä koodi - Piilota koodi

# Tämä on koodi Op_fi5889 sivulla [[Ruori]]

library(OpasnetUtils)
library(tidyverse)
library(treemap)
library(plotly)

#objects.latest("Op_en6007", code_name = "hnh2035") # [[OpasnetUtils/Drafts]] pushIndicatorGraph

##### Finnish translations
transl <- as_tibble(opbase.data("Op_fi3944", subset="Tautiluokittelu")) %>% # [[Tautitaakka Suomessa]]
  mutate(Id=as.integer(as.character(Id)))

BS <- 24

palet <- c(
  '#a6cee3','#1f78b4','#b2df8a','#33a02c','#fb9a99','#e31a1c','#fdbf6f',
  '#ff7f00','#cab2d6','#6a3d9a','#ffff99','#b15928', # First 12 colours from Colorbrewer Paired.
  'cyan2','cyan4','plum1','plum4', 'darkslategray4','darkslategray1','firebrick3'
)

###################### Graphs for the Tautitaakka auttaa hahmottamaan ... article

# DALYs by causes (risks not included)
dc <- 
  as_tibble(opasnet.csv("2/2d/IHME_Fin_Risks_by_Cause.zip", wiki="opasnet_en",
                        unzip="IHME-GBD_2017_DATA-8ce9adcf-1.csv",sep=",",dec=".",header=TRUE)) %>%
  left_join(transl[transl$Type=="Cause",], by=c("cause_id"="Id")) %>%
  mutate(cause_name = Result) %>% # transl combines some entries from cause_name to Name (in Finnish: Result)
  #  "Neglected tropical diseases and malaria",
  #  "HIV/AIDS and sexually transmitted infections",
  #  "Enteric infections" >> "Other infectious diseases"
  filter(measure_name=="DALYs (Disability-Adjusted Life Years)" & metric_name=="Number" & year == 2017) %>%
  group_by(cause_name) %>% 
  summarise(value=sum(val)) %>%
  mutate(cause_name = factor(cause_name, levels=cause_name[order(value)])) %>%
  mutate(valy = value/1000 + ifelse(value<250000, 20, -40)) # unit kDALY/a

plot_cause <- ggplot(dc2, aes(x=cause_name,weight=value/1000,fill=cause_name, label=round(value/1000)))+
  geom_bar(position="stack")+geom_text(aes(y=valy))+coord_flip()+
  guides(fill=FALSE)+
  scale_fill_manual(values = rev(palet))+ 
  labs(
    title="Tautitaakka Suomessa syittäin 2017",
    x="Tauti tai haitta",
    y="Tautitaakka (tuhatta DALYa vuodessa)")

plot_cause
# ggsave("Tautitaakka Suomessa 2017.svg", width=8, height=5) # Png conversion: 300 pixels/inch, font size 4 times larger

############## DALYs by causes and risks

dcr <- as_tibble(
  opasnet.csv("2/2d/IHME_Fin_Risks_by_Cause.zip", wiki="opasnet_en",
              unzip="IHME-GBD_2017_DATA-8c9ca17f-1.csv",sep=",",dec=".",header=TRUE)
) %>%
  left_join(transl[transl$Type=="Cause",], by=c("cause_id"="Id")) %>%
  filter(measure_name=="DALYs (Disability-Adjusted Life Years)" & metric_name=="Number" & year == 2017) %>%
  #  mutate(cause_name = factor(Result, levels=dc2$cause_name)) %>% # transl combines some entries from cause_name to Name (in Finnish: Result)
  left_join(transl[transl$Type=="Risk",], by=c("rei_id"="Id"))

dcr <- dcr %>%
  mutate(
    cause_name=factor(Result.x,levels=levels(dc$cause_name)),
    rei_name=factor(Result.y, levels = aggregate(dcr["val"],dcr["Result.y"],sum) %>% transmute(Result.y[order(val)]) %>% pull())) %>%
  group_by(rei_name, cause_name, Luokka.y) %>%
  summarise(val = sum(val))

#  mutate(rei_name = factor(rei_name, levels= dcr2$rei_name)) # transl combines some entries from cause_name to Name (in Finnish: Result)

# Strange discrepancy in two sources from IHME: especially in cardiovascular diseases. 
# Reason not known, use dcr anyway; because errors not found.
# ihme <- read.csv("C:/Users/jtue/AppData/Local/Temp/download(1).csv")
# ihme <- ihme[ihme$Measure=="DALYs",]
# sum(ihme$Value)
# [1] 911630.9
# sum(dcr$val)
# [1] 1205234
# View(
#   merge(
#     aggregate(ihme["Value"], by=ihme["Cause.of.death.or.injury"], FUN=sum),
#     aggregate(dcr["val"], by=dcr["cause_name"], FUN=sum),
#     by.x=c("Cause.of.death.or.injury"), by.y=c("cause_name")
#   )
# )


plot_risk <- ggplot(dcr, aes(x=rei_name, weight=val/1000, fill=cause_name))+geom_bar()+coord_flip()+
  scale_fill_manual(values = rev(palet)[-8])+ # Skin diseases missing, so remove that colour 
  guides(fill = guide_legend(reverse=TRUE, title=NULL, keyheight=0.8))+
  theme_gray(base_size=11)+ theme(legend.position=c(0.83,0.29)) + 
  labs(
    title = "Tautitaakka Suomessa 2017 tunnettujen riskitekijöiden mukaan",
    x="Riskitekijä", y="Tautitaakka (tuhatta DALYa vuodessa)")

plot_risk
# ggsave("Tautitaakka Suomessa 2017 riskitekijöittäin.svg", width=8, height=6) # Png conversion: 300 pixels/inch, font size 4 times larger

ruori <-   data.frame(
  Luokka.y = c(rep("Ympäristö",3),rep("Ravitsemus",4),rep("Ympäristö",3)),
  rei_name = c(
    "Aflatoksiini",
    "Lyijy",
    "Dioksiini",
    "Tyydyttyneet rasvat",
    "Suola",
    "Hedelmien liian vähäinen saanti",
    "Kasvisten liian vähäinen saanti",
    "Norovirus",
    "Listeria",
    "Toksoplasma"
  ),
  val = c(
    8,
    6,
    22,
    8190,
    27062,
    35314,
    27778,
    1,
    660,
    432
  ),
  lower = c(
    6,
    NA,
    NA,
    5857,
    1330,
    20197,
    13740,
    NA,
    330,
    270
  ),
  upper = c(
    13,
    NA,
    NA,
    11125,
    65542,
    53635,
    44716,
    NA,
    880,
    702
  )
)

dcr$rei_name <- as.character(dcr$rei_name)

# Subtract Ruori results from IHME background
dcr$val[dcr$rei_name=="Ravitsemusriskit" & dcr$cause_name=="Sydän- ja verisuonitaudit"] <-
  dcr$val[dcr$rei_name=="Ravitsemusriskit" & dcr$cause_name=="Sydän- ja verisuonitaudit"] - sum(ruori$val[ruori$Luokka.y=="Ravitsemus"])

dcr$val[dcr$rei_name=="Muut ympäristöriskit" & dcr$cause_name=="Syöpä"] <-
  dcr$val[dcr$rei_name=="Muut ympäristöriskit" & dcr$cause_name=="Syöpä"] - sum(ruori$val[ruori$Luokka.y=="Ympäristö"])

dcr <- rbind(dcr[colnames(dcr)!="cause_name"],ruori[!colnames(ruori) %in% c("upper","lower")])
dcr$rei_name[dcr$rei_name=="Ravitsemusriskit"] <- "Muut ravitsemusriskit"

pdf("Tautitaakka riskitekijöittäin.pdf", width=11.67, height=4.27)
treemap(dcr, index=c("Luokka.y","rei_name"),vSize="val",
        title=paste0("Tunnettujen riskitekijöiden tautitaakka Suomessa 2017 (",
                     round(sum(dcr$val),-3)," DALY)"),
        align.labels=list(c("center","top"),c("center","center")),
        aspRatio = 2, border.col = "gray")
dev.off()

tmp <- ruori %>%
  filter(rei_name %in% c("Aflatoksiini","Lyijy","Dioksiini","Norovirus","Listeria","Toksoplasma")) %>%
  rename(Altiste=rei_name) %>%
  mutate(Altiste = factor(Altiste, levels=ruori$rei_name[order(ruori$val)]))

thlBarPlot(tmp, xvar=Altiste, yvar=val)+
  coord_flip()+geom_errorbar(data=tmp, aes(ymin=lower, ymax=upper), width=0.25, size=0.7)+
  labs(
    title="Ruorissa tutkittujen riskien tautitaakka",
    subtitle = "Tautitaakka mikrobiologisille ja kemiallisille epäpuhtauksille (DALYa vuodessa)")

ggsave("Mikrobiologiset ja kemialliset riskit Ruorissa.svg", width=8, height=5)

tmp <- ruori %>%
  filter(!rei_name %in% c("Aflatoksiini","Lyijy","Dioksiini","Norovirus","Listeria","Toksoplasma")) %>%
  rename(Altiste=rei_name) %>%
  mutate(Altiste = factor(Altiste, levels=ruori$rei_name[order(ruori$val)]))

thlBarPlot(tmp, xvar=Altiste, yvar=val)+
  coord_flip()+geom_errorbar(data=tmp, aes(ymin=lower, ymax=upper), width=0.25, size=0.7)+
  labs(
    title="Ruorissa tutkittujen riskien tautitaakka",
    subtitle = "Tautitaakka ravitsemusriskeille (DALYa vuodessa)")

ggsave("Ravitsemusriskit Ruorissa.svg", width=8, height=5)

####################################

# Katso sivut [[:op_en:Goherr assessment]] ja [[:op_en:Health effects of Baltic herring and salmon: a benefit-risk assessment]]
objects.get('155401096341')

groups <- function(o) {
  o$Group <- paste(o$Gender, o$Ages)
  o$Group <- factor(o$Group, levels = c(
    "Female 18-45",
    "Male 18-45",
    "Female >45",
    "Male >45"
  ))
  return(o)
}

varit12 <- c(
  '#2f62ad', # THL-värit, koko väripaletti. Nro 2
  '#7cd0d8', # 4
  '#571259', # 9
  '#5faf2c', # 11
  '#bf4073', # 14
  '#3b007f', # 18
  '#16994a', # 20
  '#cccc72', # 22
  '#0e1e47', # 3
  '#25a5a2', # 5
  '#cc7acc', # 7
  '#244911' # 12
)

#### Burden of disease

# Figure 5. from Goherr assessment manuscript

if(FALSE) tmp <- groups(BoD * info) else tmp <- groups(BoDRaw * info)

tmp <- oapply(
  tmp[!grepl("TWI", tmp$Resp) & tmp$Background=="Yes",],
  INDEX=c("Resp","Group","Country","Cons.policy","Background"),
  mean
)@output

# levels(tmp$Group)
# [1] "Female 18-45" "Male 18-45"   "Female >45"   "Male >45"    
levels(tmp$Group) <- c("Naiset 18-45","Miehet 18-45","Naiset >45","Miehet >45")

#levels(tmp$Resp)
#[1] "Stroke"           "Heart (CHD)"      "Cancer"           "Child's IQ"       "Infertility"     
#[6] "Tooth defect"     "Dioxin TWI"       "TWI 2018"         "Vitamin D intake"
levels(tmp$Resp) <- c("Aivohalvaus","Sepelvaltimotauti","Syöpä","Lapsen ÄO","Hedelmättömyys",
                      "Hammasvaurio","","","D-vitamiini")

fig22 <- ggplot(tmp[tmp$Country=="FI" & tmp$Cons.policy=="BAU",],
                aes(x=Group, weight=Result, fill=Resp))+
  geom_bar()+facet_grid(Cons.policy ~ Country)+
  theme_grey(base_size=BS-8)+
  theme(
    legend.position = "bottom"
    #    axis.text.x = element_text(angle = -90)
  )+
  labs(
    title="Itämeren kalan aiheuttama tautitaakka Suomessa ryhmittäin",
    y = "Tautitaakka (DALY/a)",
    fill="",
    x=""
  )+
  scale_fill_manual(values=varit12[-(7:8)])

fig22
ggsave("Itämeren kalan tautitaakka Suomessa.svg", width=8, height=5)

######### Figure 6.

tmp <- groups(BoDRaw * info)

#> levels(tmp$Resp)
#[1] "Stroke"           "Heart (CHD)"      "Cancer"           "Child's IQ"       "Infertility"     
#[6] "Tooth defect"     "Dioxin TWI"       "TWI 2018"         "Vitamin D intake"
levels(tmp$Resp) <- c("Aivohalvaus","Sepelvaltimotauti","Syöpä","Lapsen ÄO","Hedelmättömyys",
                      "Hammasvaurio","TWI 2001","TWI 2018","D-vitamiini")

tmp@output <- rbind(
  cbind(tmp@output,Focusgroup = "Kaikki"),
  cbind(tmp@output[tmp$Group=="Female 18-45",],Focusgroup = "Nuoret naiset")
)

tmp <- oapply(
  tmp[tmp$Cons.policy=="BAU" & tmp$Country=="FI",],
  INDEX=c("Resp","Background","Focusgroup","Country"),
  mean
)@output

tmp <- rbind(
  cbind(
    Objective="Kokonaisterveys, oletus",
    tmp[tmp$Background=="Yes" & !grepl("TWI",tmp$Resp),]
  ),
  cbind(
    Objective="Kokonaisterveys, taustatta",
    tmp[tmp$Background=="No" & !grepl("TWI",tmp$Resp),]
  ),
  cbind(
    Objective=tmp$Resp,
    tmp
  )[grepl("TWI",tmp$Resp),]
)

sums <- aggregate(tmp["Result"], by=tmp[c("Objective","Focusgroup","Country")],sum)
fig22b <- ggplot(tmp, aes(x=Objective, weight=Result))+
  geom_bar(aes(fill=Resp))+facet_grid(Country ~ Focusgroup)+
  theme_grey(base_size=BS-8)+
  theme(
    legend.position = "bottom",
    axis.text.x = element_text(angle = -15, hjust=0.5)
  )+
  geom_text(data=sums, size=6, aes(label=round(Result,-2),y=pmax(200,Result+200)))+
  labs(
    title="Tautitaakka eri tavoitteiden näkökulmasta",
    y = "Tautitaakka (DALY/a)",
    fill="",
    x=""
  )+
  scale_fill_manual(values=varit12)
fig22b

ggsave("Itämeren kalan tautitaakka eri näkökulmista.svg", width=10, height=7)

############################ Health care costs

dat <- scrape.webtable(
  "https://en.wikipedia.org/wiki/List_of_countries_by_total_health_expenditure_per_capita",
  6) 
colnames(dat) <- c("Country","Y2000","Y2005","Y2010","Y2015")
dat$Y2015 <- as.numeric(gsub(",","",as.character(dat$Y2015)))
dat$Country <- as.character(dat$Country)
dat$Country[match(c(
  "Iran (Islamic Republic of)",
  "Lao People's Democratic Republic",
  "United Republic of Tanzania",
  "United States of America",
  "Venezuela (Bolivarian Republic of)",
  "Viet Nam"
),dat$Country)] <- c("Iran","Laos","Tanzania","United States","Venezuela","Vietnam")

dat2 <- read.csv("C:/Users/jtue/AppData/Local/Temp/IHME-GBD_2017_DATA-96ba4b83-1.csv")
levels(dat2$location_name)[match(c(
  "The Bahamas","The Gambia"),levels(dat2$location_name))] <- c("Bahamas","Gambia")

dat3 <- merge(dat,dat2, by.x="Country",by.y="location_name", all=TRUE)
dat3$label <- ifelse(dat3$Country %in% c("Finland","Sweden","United States","Poland"), dat3$Country, " ")

tmp <- dat3[dat3$metric_name=="Rate" & dat3$cause_name=="All causes",]
tmp$label[match(c("Finland","Sweden","United States","Poland"),tmp$label)] <- c("Suomi","Ruotsi", "USA","Puola")

ggplot(tmp, aes(x=Y2015,y=val/100000, label=label, colour=label))+
  geom_point()+geom_text()+
  labs(
    title="Tautitaakka terveysmenojen funktiona maittain 2015",
    y="Tautitaakka per henkilö (DALY)",
    x="Terveydenhuoltomenot per henkilö (USD)"
  )

ggsave("Tautitaakka terveysmenojen funktiona maittain.svg", width=9, height=5)

pl <- plot_ly(tmp, x=~Y2015, y=~val/100000,type="scatter", mode="markers", hovertext=~Country) %>% #, text=~label,color=~label) %>%
  layout(
    title="Tautitaakka terveysmenojen funktiona maittain 2015",
    xaxis=list(title="Terveydenhuoltomenot per henkilö (USD)"),
    yaxis=list(title="Tautitaakka per henkilö (DALY)")
  )

pl
# pushIndicatorGraph(pl, 103)#, API_KEY= apikey)

Viitteet

↑ Drake T. (2014) Priority setting in global health: towards a minimum DALY value. Health Economics Letter 23:2:248-252. https://doi.org/10.1002/hec.2925
↑ Brent RJ. (2011) An implicit price of a DALY for use in a cost-benefit analysis of ARVs. Applied Economics 43:11:1413-1421. https://doi.org/10.1080/00036840802600475
↑ Minstry R. (2011) Methodology for valuing health impacts on the SHEcan project. IOM Research Project P937/96. http://ec.europa.eu/social/BlobServlet?docId=10178&langId=en
↑ The Interdepartmental Group on Costs and Benefits Noise Subject Group. (2014) Environmental Noise: Valuing impacts on sleep disturbance, annoyance, hypertension, productivity and quiet. https://assets.publishing.service.gov.uk/government/uploads/system/uploads/attachment_data/file/380852/environmental-noise-valuing-imapcts-PB14227.pdf
↑ The Interdepartmental Group on Costs and Benefits Noise Subject Group (IGCB(N)). (2010) Noise & Health – Valuing the Human Health Impacts of Environmental Noise Exposure. https://khub.net/c/document_library/get_file?uuid=6a229977-e27a-43c5-a780-e224649bd2df&groupId=6197021
↑ Berry BF, Flindell IH. (2009) Estimating Dose-Response Relationships between Noise Exposure and Human Health Impacts in the UK. BEL Technical Report 2009-002. https://webarchive.nationalarchives.gov.uk/20130123222353/http://archive.defra.gov.uk/environment/quality/noise/igcb/documents/tech-report.pdf
↑ Hammitt, J.K. (2013) Admissible utility functions for health, longevity, and wealth: integrating monetary and life-year measures. J Risk Uncertain 47: 311. https://doi.org/10.1007/s11166-013-9178-4
↑ Brecht Devleesschauwer, Nicolas Praet, Niko Speybroeck, Paul R. Torgerson, Juanita A. Haagsma, KrisDe Smet, K. Darwin Murrell, Edoardo Pozio, Pierre Dorny. (2015) The low global burden of trichinellosis: evidence and implications. International Journal for Parasitology 45, 2–3, 95-99. [1] [2]

Katso myös

Ruori-hankkeen tautitaakka-arviot

[1] Drake T. (2014) Priority setting in global health: towards a minimum DALY value. Health Economics Letter 23:2:248-252. https://doi.org/10.1002/hec.2925

[2] Brent RJ. (2011) An implicit price of a DALY for use in a cost-benefit analysis of ARVs. Applied Economics 43:11:1413-1421. https://doi.org/10.1080/00036840802600475

[3] Minstry R. (2011) Methodology for valuing health impacts on the SHEcan project. IOM Research Project P937/96. http://ec.europa.eu/social/BlobServlet?docId=10178&langId=en

[4] The Interdepartmental Group on Costs and Benefits Noise Subject Group. (2014) Environmental Noise: Valuing impacts on sleep disturbance, annoyance, hypertension, productivity and quiet. https://assets.publishing.service.gov.uk/government/uploads/system/uploads/attachment_data/file/380852/environmental-noise-valuing-imapcts-PB14227.pdf

[5] The Interdepartmental Group on Costs and Benefits Noise Subject Group (IGCB(N)). (2010) Noise & Health – Valuing the Human Health Impacts of Environmental Noise Exposure. https://khub.net/c/document_library/get_file?uuid=6a229977-e27a-43c5-a780-e224649bd2df&groupId=6197021

[6] Berry BF, Flindell IH. (2009) Estimating Dose-Response Relationships between Noise Exposure and Human Health Impacts in the UK. BEL Technical Report 2009-002. https://webarchive.nationalarchives.gov.uk/20130123222353/http://archive.defra.gov.uk/environment/quality/noise/igcb/documents/tech-report.pdf

[7] Hammitt, J.K. (2013) Admissible utility functions for health, longevity, and wealth: integrating monetary and life-year measures. J Risk Uncertain 47: 311. https://doi.org/10.1007/s11166-013-9178-4

[8] Brecht Devleesschauwer, Nicolas Praet, Niko Speybroeck, Paul R. Torgerson, Juanita A. Haagsma, KrisDe Smet, K. Darwin Murrell, Edoardo Pozio, Pierre Dorny. (2015) The low global burden of trichinellosis: evidence and implications. International Journal for Parasitology 45, 2–3, 95-99. [1] [2]

[1]

[2]

[3]

[4]

[5]

[6]

[7]

[8]

Ruori

Sisällys

Rajaus

Kysymys

Aikataulu ja käyttäjät

Vastaus

Perustelut

Data

Malliparametrit

Laskenta

Arviointimalli

Dioksiiniskenaario

Tautitaakkakuvia

Viitteet

Katso myös

Navigointivalikko