クロス集計の視覚化 モザイクプロットとその他の分析

クロス集計が重要であることは、どのような書籍やサイトを見ても散々言われています。そして、本来は集計そのものが大切なのではなく、その結果から何が読み取れるかを考えることが最も大切なプロセスです。しかし、何となくクロス集計表の数字を眺めているだけでは、新しい知見を得ることは難しい場合が多いと思います。そこで、クロス集計の結果を視覚的に理解できるようにしてみたいと思います。

では、クロス集計の視覚化には、どのようなグラフが最適でしょうか。恐らく最も単純なグラフは、モザイクプロットと呼ばれるグラフです。

モザイクプロットの何がいいのでしょうか。それは各要素の「割合」と「サイズ」が一目で把握できることではないでしょうか。この二つを同時に把握できるグラフはなかなか他にありません。

残念なことに、エクセルの標準機能の中にはこのモザイクプロットを作成する機能はありません（2018年5月現在）。他の様々なグラフ機能がある中で、何故、これほど有用なモザイクプロットの機能がないのでしょうか...。考えていてもしょうがないので、何とか作成する方法を探してみることにします。

簡単な方法としては、専用のソフトやアドインを探す、ということなのでしょうけれども、有料のものも多く、手を出しづらいかもしれません。しかし、高品質なものを求めているのであれば、代価を支払ってでもそのようなソフトを購入すべきです。

ただし、もっと気軽にモザイクプロットを作成したいのであれば、ネット上で提案されている方法を試してみるのも良いかもしれません。個人的に、しっくりくる方法を見つけることができなかったため、モザイクプロットを作成するVBAを書いてみることにします。アイディアは陳腐なもので、「クロス集計表の各数字の大小に応じた四角図形を作成・並べる」、というものです。

Sub myMosaicPlot()

'Use InputBox to let a user select a table range
    Dim myRange As Range
    Set myRange = Application.InputBox(Prompt:="Select cross table. Include row & column headers.", Type:=8)

'Get start row & column, and number of rows & columns of the table
    Dim myRow As Long, myRows As Long, myColumn As Long, myColumns As Long, Table_Value() As Variant, Table_Ratio() As Variant, Column_Ratio() As Variant
    
    myRow = myRange.Row
    myColumn = myRange.Column
    myRows = myRange.Rows.Count
    myColumns = myRange.Columns.Count

    ReDim Table_Value(1 To myRows - 1, 1 To myColumns - 1)
    ReDim Table_Ratio(1 To myRows - 1, 1 To myColumns - 1)
    ReDim Column_Ratio(1 To myColumns - 1)


'Get value & ratio into objects
        For j = 1 To myColumns - 1
            For i = 1 To myRows - 1
            Table_Value(i, j) = ActiveSheet.Cells(myRow + i, myColumn + j)
            Table_Ratio(i, j) = Table_Value(i, j) / WorksheetFunction.Sum(myRange)
            Column_Ratio(j) = Column_Ratio(j) + Table_Value(i, j)
            Next
        Column_Ratio(j) = Column_Ratio(j) / WorksheetFunction.Sum(myRange)
        Next


'Create a box chart for each cell
    Entiresize = 300 'Size of the chart
    FromColumn = 100 'Location of the chart
    myspace = 3 'space between each box
    
    Dim myShape() As Shape, myGroup() As ShapeRange, myPlot As ShapeRange
    ReDim myShape(1 To myRows - 1, 1 To myColumns - 1) As Shape, myGroup(1 To myRows - 1) As ShapeRange
    
        With ActiveSheet
            For j = 1 To myColumns - 1
            FromRow = 100
                For i = 1 To myRows - 1
            
                Set myShape(i, j) = .Shapes.AddShape(msoShapeRectangle, FromColumn, FromRow, Column_Ratio(j) * Entiresize, Table_Ratio(i, j) / Column_Ratio(j) * Entiresize)
                
                    With myShape(i, j).TextFrame2
                    .TextRange.Characters.Text = WorksheetFunction.Trim(ActiveSheet.Cells(myRow + i, myColumn + j).Text)
                    .TextRange.ParagraphFormat.Alignment = msoAlignCenter
                    .VerticalAnchor = msoAnchorMiddle
                    End With
            
                FromRow = FromRow + Table_Ratio(i, j) * Entiresize / Column_Ratio(j) + myspace
            
                Next
            
            FromColumn = FromColumn + Column_Ratio(j) * Entiresize + myspace
            Next
            
            For i = 1 To myRows - 1
                For j = 1 To myColumns - 1
            
                myShape(i, j).Select Replace:=False
            
                Next j
            
                With Selection
                .ShapeRange.Group.Select
                Set myGroup(i) = Selection.ShapeRange
                .ShapeRange.Fill.ForeColor.ObjectThemeColor = msoThemeColorAccent & (i-1) Mod 6 + 5
                .ShapeRange.Line.ForeColor.ObjectThemeColor = msoThemeColorAccent & (i-1) Mod 6 + 5
                End With
        
            .Range("A1").Select
        
            Next i
        
            For i = 1 To myRows - 1
            myGroup(i).Select Replace:=False
            Next i
        
        Selection.ShapeRange.Group.Select
        Set myPlot = Selection.ShapeRange
        .Range("A1").Select
    
    
'Add column headers at the bottom of the plot
    Dim myColumnHeaders() As Shape, ColumnHeader As String, myColumnHeader As ShapeRange
    ReDim myColumnHeaders(1 To myColumns - 1) As Shape

        FromColumn = 100
            For i = 1 To myColumns - 1
            ColumnHeader = .Cells(myRow, myColumn + i).Value
            Set myColumnHeaders(i) = .Shapes.AddShape(msoShapeRectangle, FromColumn, FromRow, Column_Ratio(i) * Entiresize, 50)
            FromColumn = FromColumn + Column_Ratio(i) * Entiresize + myspace
        
                With myColumnHeaders(i).TextFrame2
                .TextRange.Characters.Text = ColumnHeader
                .TextRange.ParagraphFormat.Alignment = msoAlignCenter
                .VerticalAnchor = msoAnchorMiddle
                .TextRange.Font.Fill.ForeColor.RGB = RGB(0, 0, 0)
                End With
                With myColumnHeaders(i)
                .Fill.Visible = msoFalse
                .Line.Visible = msoFalse
                End With
            Next
        
            For i = 1 To myColumns - 1
            myColumnHeaders(i).Select Replace:=False
            Next
        
            With Selection
            .ShapeRange.Group.Select
            Set myColumnHeader = Selection.ShapeRange
            End With
            .Range("A1").Select
        
        
'Add row headers on the right of the plot
    Dim myRowHeaders() As Shape, RowHeader As String, myRowHeader As ShapeRange
    ReDim myRowHeaders(1 To myRows - 1) As Shape

        FromRow = 100
            For i = 1 To myRows - 1
            RowHeader = .Cells(myRow + i, myColumn).Value
            Set myRowHeaders(i) = .Shapes.AddShape(msoShapeRectangle, FromColumn, FromRow, 50, Table_Ratio(i, myColumns - 1) / Column_Ratio(myColumns - 1) * Entiresize)
            FromRow = FromRow + Table_Ratio(i, myColumns - 1) * Entiresize / Column_Ratio(myColumns - 1) + myspace
        
                With myRowHeaders(i).TextFrame2
                .TextRange.Characters.Text = RowHeader
                .TextRange.ParagraphFormat.Alignment = msoAlignLeft
                .VerticalAnchor = msoAnchorMiddle
                .TextRange.Font.Fill.ForeColor.ObjectThemeColor = msoThemeColorAccent & (i-1) Mod 6 + 5
                End With
                With myRowHeaders(i)
                .Fill.Visible = msoFalse
                .Line.Visible = msoFalse
                End With
            Next
        
            For i = 1 To myRows - 1
            myRowHeaders(i).Select Replace:=False
            Next
        
            With Selection
            .ShapeRange.Group.Select
            Set myRowHeader = Selection.ShapeRange
            End With
            .Range("A1").Select
    
    
'Add Y axis (0%, 20%, 40%, 60%, 80%, and 100%) on the left of the plot
    Dim myShape_Yaxis() As Shape
    ReDim myShape_Yaxis(1 To 6) As Shape

        FromColumn = 100
        FromRow = 100
    
            For i = 1 To 6
            Set myShape_Yaxis(i) = .Shapes.AddShape(msoShapeRectangle, FromColumn - 40, FromRow - 15 + ((i - 1) * (Entiresize + (myRows - 2) * myspace)) / 5, 40, 30)
                With myShape_Yaxis(i).TextFrame2
                .TextRange.Characters.Text = (6 - i) * 20 & "%"
                .TextRange.ParagraphFormat.Alignment = msoAlignCenter
                .VerticalAnchor = msoAnchorMiddle
                .TextRange.Font.Fill.ForeColor.RGB = RGB(0, 0, 0)
                End With
                With myShape_Yaxis(i)
                .Fill.Visible = msoFalse
                .Line.Visible = msoFalse
                End With
            Next
        
            For i = 1 To 6
            myShape_Yaxis(i).Select Replace:=False
            Next
        
            With Selection
            .ShapeRange.Group.Select
            Set myYaxis = Selection.ShapeRange
            End With
            .Range("A1").Select
        
        End With


'Grouping all sub-groups
    myPlot.Select
    myColumnHeader.Select Replace:=False
    myRowHeader.Select Replace:=False
    myYaxis.Select Replace:=Fals
    
    Selection.ShapeRange.Group.Select
    
End Sub

コードを実行すると、Inputboxが現れますので、ここにクロス集計表の範囲を指定します。その際に、行と列のヘダーを含めるようにします。

すると、以下のようなモザイクプロットが作成されます。

図形はグループ化しているため、特定の行グループの色を変えたい場合などは、一度グループ解除をする必要があります…。大変面倒なのですが、自作のコードなんてこんなものだろうと諦め、そこは目をつぶることにしています。何はともあれ、これでクロス集計をモザイクプロットとして視覚化することができました。縦方向に見れば、各列要素の割合が見て取れますし、また横方向を見ることによって、各列の規模を把握することができます。

モザイクプロットの他にも、クロス集計の視覚化として、コレスポンデンス分析というものがあります。マーケティングの分野ではとても有名な統計分析手法で、行要素間および列要素間の関係を座標上で見て取ることができます。残念ながら、この機能もエクセルにはないため、他の方法に頼ることになります。エクセルで完結する方法もないことはないらしいのですが、ここは統計分析に特化した”R”というアプリケーションを使い、分析と視覚化の処理を行います（この方法については、ここでは割愛します。）。結果は以下の通りです。

縦軸と横軸の座標の上で、それぞれの軸に何かしらの意味を持たせ、行要素と列要素のそれぞれをポジショニングしています。ポジショニングと言うといかにもマーケティングの言葉に聞こえますが、それ以外の場合においても、データから物事のトレンドを見抜く上で助けになります。

コレスポンデンス分析は視覚的に訴えやすく、いかにも統計分析をしているような気にさせてくれるかもしれません。しかし、コレスポンデンス分析の結果の解釈や、その計算方法、その背後にある考え方などを理解することは（少なくとも統計を勉強している方でなければ）容易ではありません。そのような状況で上記のような座標図を資料として使用することは、だいぶリスクが高いと言えるでしょう。

しかしながら、コレスポンデンス分析の結果を、何とか説明可能な範囲で利用できないでしょうか。一つの方法は、コレスポンデンス分析の結果をもとにクロス集計表を「並び替える」ことです。

唐突に「並び替える」というワードが出てきましたが、これには立派な意味があります。コレスポンデンス分析の計算の課程の中で、「各行および各列の項目にそれぞれ数値を割り当てる」というプロセスがあります。そして割り当てられた数値をもとに行と列を移動させるのですが、その様子が「行と列の並び替え」に当たります。この割り当てられる数値は複数存在するのですが（行数と列数の少ない方の数から１を引いた数）、その中の最初の結果を使用し、クロス集計表を並び替えたいと思います。

上記に示したクロス集計表に対して、Rを使いコレスポンデンス分析を行った結果、各行と各列に割り当てられた数値は以下の通りです（ここでも詳細は割愛します）。

Row1:Row8 {-1.46249899, 1.79231815, 0.06866948, -1.54543379, 1.12795191, 0.29087298, 0.09733284, -0.41117815}

Column1:Column6 {-1.2818798, -1.3445163, 0.65211, 1.5695245, 0.4157471, 0.3883627}

並び替え機能を使い、まず行項目の数値を使い降順に並び替えます。その結果を転置させ（Special PasteのTransposeを使えば簡単に行うことができます）、今度は列項目の数値を使い降順に並び替えます。最後に、もう一度転置をさせれば、下図の左のようなクロス集計表になります。このクロス集計表をもとに作成したモザイクプロットが下図の右になります。

最初の結果よりも、明らかに類似項目（特に類似列）がまとまっていたり、全体のトレンドや、逆にトレンドから外れているような項目を見つけやすくなっています。項目の数が多くなると、感覚的にこのような並び替えを行うことは非常に困難になるので、上記のような方法を試してみる価値はあるのではないでしょうか。

この方法では、コレスポンデンス分析の結果のほんの一部しか使用していないため、結果の解釈や表現としては厳密には適切とは言えないでしょう。それでも、最終的なグラフとしてモザイクプロットを使用していることにより、第三者にとっても比較的理解しやすい表現となります。特に、コレスポンデンス分析の座標図からは、各項目のサイズが全く見て取れないのですが、その点モザイクプロットであれば、各項目のサイズをはっきりと視覚的に確認することができます。