社会疫学的指標を考慮した都道府県別の熱中症搬送人員数の予測と実際

　都道府県別の熱中症搬送人員数の予測と実際をEXCELの組み合わせグラフで描くでは独立変数として日最高気温，日平均水蒸気圧，65歳以上人口，人口密度を投入し都道府県別の熱中症搬送人員数を予測した．以前の記事ではe-Statからの社会疫学的指標を加えて熱中症搬送人員数を分析した．社会疫学的指標としては日最高気温，日平均水蒸気圧，都道府県人口に加えて過去30日間の平均気温，エアコン保有台数，年間収入のジニ係数，光熱・水道費，実収入，第1次産業就業者比率，第2次産業就業者比率，都市公園数，都市緑化割合，自然公園割合，自然公園数，生活保護被保護人員である．

　今回は社会疫学的指標を独立変数として加えた熱中症搬送人員数の予測と実際を示す．

クエリ

　SQL Serverで下記クエリを実行する．

USE HeatStrokeDB
GO
WITH	CTE_MOVING_AVERAGE(date, pref, Avg30)
AS(
SELECT
    D.年月日
,	D.都道府県
,	AVG(D.日平均気温) 
		OVER (PARTITION BY D.都道府県
			  ORDER BY D.年月日 ASC
			  ROWS BETWEEN 29 PRECEDING AND CURRENT ROW) AS '移動平均30日間'
FROM	dbo.T_DailyAvgTemp	AS D
)
SELECT	M.都道府県コード	AS PrefCode
,	M.都道府県	AS Pref
,	M.年月日	AS Date
,	YEAR(M.年月日)	AS YEAR
,	CAST(EXP(-22.2
+	0.3141	* M.日最高気温
-	0.1068	* CTE_MOVING_AVERAGE.Avg30
+	0.09617	* V.日平均蒸気圧
+	LOG(P.総人口)
+	0.0001203	* A.[ルームエアコン【台】]
-	3.301	* G.年間収入のジニ係数
+	0.00009799	* I.[光熱・水道費【円】]
-	0.000002910	* I.[実収入【円】]
+	0.01777	* L.第１次産業就業者比率*100
-	0.005739	* L.第２次産業就業者比率*100
+	0.00002997	* PA.H9101_都市公園数
-	0.1554	* (PA.[H920502_都市緑地面積【ｈａ】]/dbo.T_AREA.[B1102_総面積【ｈａ】])*100
-	0.004013	* (CAST(NA.[B2101_自然公園面積【ｈａ】] AS float)	
/	CAST(dbo.T_AREA.[B1102_総面積【ｈａ】] AS float))*100
+	0.02068	* NA.[B2102_都道府県立自然公園数【箇所】]
-	0.0000005096	* W.[生活保護被保護実人員【人】]
)	AS int)	AS Predict
,	H.[搬送人員（計）]	AS Real
FROM	dbo.T_MaxTemperature	AS M
INNER	JOIN	CTE_MOVING_AVERAGE
ON	CTE_MOVING_AVERAGE.date=M.年月日
AND	CTE_MOVING_AVERAGE.pref=M.都道府県
INNER	JOIN	dbo.T_HeatStroke	AS H
ON	M.都道府県コード = H.都道府県コード
AND	M.年月日 = H.日付
INNER	JOIN	dbo.T_VaporPressure	AS V
ON	M.都道府県コード=V.都道府県コード
AND	M.年月日=V.年月日
INNER	JOIN	dbo.T_Population	AS P
ON	M.都道府県コード = P.都道府県コード
AND	YEAR(M.年月日) = P.調査年
INNER	JOIN	dbo.T_AirCon	AS A
ON	M.都道府県コード = LEFT(A.都道府県コード, 2)
AND	CASE WHEN YEAR(M.年月日) >= 2014 THEN 2014 ELSE
	CASE WHEN YEAR(M.年月日) >= 2009 THEN 2009 ELSE	2004 END END = A.調査年
INNER	JOIN	dbo.T_Gini	AS G
ON	M.都道府県コード = LEFT(G.都道府県コード, 2)
AND	CASE WHEN	YEAR(M.年月日) >= 2014 THEN 2014 ELSE 2009 END = G.調査年
INNER	JOIN	dbo.T_Income	AS I
ON	M.都道府県コード = LEFT(I.都道府県コード, 2)
AND	CASE WHEN YEAR(M.年月日) >= 2014 THEN 2014 ELSE
	CASE WHEN YEAR(M.年月日) >= 2009 THEN 2009 ELSE 2004 END END = I.調査年
INNER	JOIN	dbo.T_LaborForce	AS L
ON	CASE WHEN YEAR(M.年月日) >= 2020 THEN 2020 ELSE
	CASE WHEN YEAR(M.年月日) >= 2015 THEN 2015 ELSE
	CASE WHEN YEAR(M.年月日) >= 2010 THEN 2010 ELSE 2005 END END END = L.調査年
AND	M.都道府県コード = LEFT(L.都道府県コード, 2)
INNER	JOIN	dbo.T_PARKS	AS PA
ON	M.都道府県コード = LEFT(PA.都道府県コード, 2)
AND	CASE WHEN	YEAR(M.年月日) >= 2021 THEN 2021 ELSE YEAR(M.年月日) END = PA.調査年
INNER	JOIN	dbo.T_NaturePark	AS NA
ON	CASE WHEN YEAR(M.年月日) >= 2021 THEN 2021 ELSE YEAR(M.年月日) END = NA.調査年
AND	M.都道府県コード = LEFT(NA.都道府県コード, 2)
INNER	JOIN	dbo.T_AREA
ON	M.都道府県コード = LEFT(dbo.T_AREA.都道府県コード, 2)
AND	CASE WHEN	YEAR(M.年月日) >= 2021 THEN 2021 ELSE YEAR(M.年月日) END = dbo.T_AREA.調査年
INNER	JOIN	dbo.T_Wellfare	AS W
ON	M.都道府県コード = LEFT(W.都道府県コード,2)
AND	YEAR(M.年月日) = W.調査年
ORDER	BY	M.都道府県コード, M.年月日

(71656 行処理されました)

EXCEL VBAでの処理

　EXCELで下記プロシージャを実行する．

Sub makechart()

Dim mySh1   As Worksheet
Dim mySh2   As Worksheet

Dim myLstObj As ListObject

Dim h       As Long
Dim myRng1  As Range
Dim i       As Long
Dim Cht     As Chart

Dim j       As Long
Dim myXValue()  As Date
Dim myValue1()  As Integer
Dim myValue2()  As Integer

Dim SeriesM As Series
Dim SeriesR As Series
Dim myPref  As String

Set mySh1 = Worksheets("Sheet1")
Set myLstObj = mySh1.ListObjects(1)

For h = 1 To 47

Set mySh2 = Worksheets.Add

With mySh2
    For i = 2008 To 2019
        Set Cht = .Shapes.AddChart2(XlChartType:=xlColumnClustered, _
                                           Left:=200 * ((i - 2008) Mod 4), _
                                            Top:=200 * ((i - 2008) \ 4), _
                                          Width:=200, _
                                         Height:=200).Chart
        With myLstObj
            .Range.AutoFilter field:=1, Criteria1:=h
            .Range.AutoFilter field:=4, Criteria1:=i
            Set myRng1 = Intersect(.DataBodyRange, _
                                   .Range.SpecialCells(xlCellTypeVisible))
            myPref = myRng1.Cells(1, 2)
            For j = 0 To myRng1.Rows.Count - 1
                ReDim Preserve myXValue(j)
                ReDim Preserve myValue1(j)
                ReDim Preserve myValue2(j)
                
                myXValue(j) = myRng1.Cells(j + 1, 3)
                myValue1(j) = myRng1.Cells(j + 1, 5)
                myValue2(j) = myRng1.Cells(j + 1, 6)
            Next j
            Set SeriesM = Cht.SeriesCollection.NewSeries
            With SeriesM
                .Name = "Model"
                .XValues = myXValue
                .Values = myValue1
                .ChartType = xlLine
                .Format.Line.Weight = 1#
                '.Format.Line.ForeColor.ObjectThemeColor = msoThemeColorAccent2
            End With
            Set SeriesR = Cht.SeriesCollection.NewSeries
            With SeriesR
                .Name = "Real"
                .XValues = myXValue
                .Values = myValue2
                .ChartType = xlColumnClustered
            End With
            .Range.AutoFilter field:=4
            .Range.AutoFilter field:=1
        End With
        With Cht
            .HasTitle = True
            .ChartTitle.Caption = i
            .ChartGroups(1).GapWidth = 0
        End With
    Next i
    .Name = myPref
End With
Next h
End Sub