トップ > 頻度分析 >

日本語文章の頻度分析

本格的な分析であれば,KAKASI( kakasi.namazu.org ),ChaSen(茶筌, http://chasen.aist-nara.ac.jp/ )MeCab(和布蕪, http://chasen.org/~taku/software/mecab/ )といった形態素解析システムを使用する必要があります。
しかし,単に日本語の文章を切り分けて頻度分析するぐらいなら,ワードVBAだけでも可能です。翻訳者は大まかな頻度のみ分かれば,訳語の選定に 役立つと思うので,これくらいの情報でも十分なのではないかと思います。
何より,ワードだけでできるので簡単です。
最初に文章を切り分け,文字列順にソート。次に重複文字列を削除し,今度は頻度順に並べ替える,という手順になっています。

SEO 対策として,Webページに含まれるキーワードの分析がはやっていますが, このマクロで,キーワードを選定,列挙することもできるでしょう。

このマクロを,ワード文書として入手したいという方は, メールにてお問い合わせください。

[Word VBAモジュール。CountWords()を呼んでください。]


Attribute VB_Name = "Frq_Module"

'==============================
'語彙頻度表示マクロ
'==============================

Sub CountWords()

  Dim values() As String
  Dim WCount() As Integer
  Dim doc_range As Range
  Dim word_object As Object
  Dim word_text As String
  Dim num_words As Long
  Dim txt As String
  Dim i As Long
  Dim j As Long
  Dim doc As Document
  Dim intCount, intTotalCount, intWordCount As Integer
  
    
  Selection.HomeKey Unit:=wdStory
    
  If Selection Is Nothing Then
    MsgBox "No document is open."
    Exit Sub
  End If
    
  StatusBar = "語彙数を計測します。(しばらくお待ちください。)"
    
    
  If Selection.Type = wdSelectionIP Then
    Set doc_range = ActiveDocument.Content
  Else
    Set doc_range = Selection.Range
  End If

  intTotalCount = doc_range.Words.Count
  intCount = 0
  
  ReDim values(0 To doc_range.Words.Count)
  ReDim WCount(0 To doc_range.Words.Count)
  
  
  For Each word_object In doc_range.Words
    If (word_object.Style <> "_code") And (word_object.Text <> "") Then
      word_text = LCase$(Trim$(word_object.Text))
        
      If Len(Trim(word_text)) <> 0 Then
        If Asc(word_text) <> 13 Then
            StatusBar = "登録中(" & intCount & "/" & intTotalCount & ")"
            num_words = num_words + 1
            values(num_words) = word_text
            intCount = intCount + 1
        
        End If
      End If
      
    End If
  Next word_object

  StatusBar = "ソート中(並べ替え中)"

  ShellSortStrings values(), 0, num_words
  
  j = 1
  intWordCount = 1
  For i = 2 To num_words
    If values(i) <> values(j) Then
      j = j + 1
      values(j) = values(i)
      WCount(j - 1) = intWordCount
      intWordCount = 1
    Else
      intWordCount = intWordCount + 1
    End If
      
  Next i
  WCount(j) = intWordCount
  num_words = j
  
  '下の行を消し,下のコメントアウトを実行するようにしても良い。
  
  ShellSortNumsWithStr WCount(), values(), 0, num_words
  
  Set doc = Documents.Add
  For i = 1 To num_words
    Selection.TypeText values(i) & vbTab & WCount(i) & vbCrLf
  Next i
   
  'Selection.WholeStory
  'Selection.Sort FieldNumber:="フィールド  2", SortFieldType:=wdSortFieldNumeric, _
  'SortOrder:=wdSortOrderDescending, FieldNumber2:=""
  'Selection.MoveDown Unit:=wdLine, Count:=1
  


  Selection.TypeText "----------" & vbCrLf
  Selection.TypeText num_words & " words." & vbCrLf

End Sub

Sub ShellSortStrings(values() As String, Start As Long, Count As Long)
    Dim gap As Long
    Dim i As Long
    Dim j As Long
    Dim StrTemp As String
    
    gap = 1
    While gap * 3 < Count - Start
        gap = gap * 3 + 1
    Wend
    
    While gap > 0
        
        For k = gap + 1 To Count
            strTmp = values(k)
            j = k
            Do While j > gap
                If values(j - gap) > strTmp Then
                    values(j) = values(j - gap)
                    j = j - gap
                Else
                    Exit Do
                End If
            Loop
            values(j) = strTmp
        Next k
        gap = gap / 3
    Wend
End Sub

Sub ShellSortNumsWithStr(values() As Integer, Strings() As String, Start As Long, Count As Long)
    Dim gap As Long
    Dim i As Long
    Dim j As Long
    Dim Temp As Integer
    Dim StrTemp As String
    
    gap = 1
    While gap * 3 < Count - Start
        gap = gap * 3 + 1
    Wend
    
    While gap > 0
        
        For k = gap + 1 To Count
            Tmp = values(k)
            StrTemp = Strings(k)
            j = k
            Do While j > gap
                If values(j - gap) < Tmp Then
                    values(j) = values(j - gap)
                    Strings(j) = Strings(j - gap)
                    j = j - gap
                Else
                    Exit Do
                End If
            Loop
            values(j) = Tmp
            Strings(j) = StrTemp
        Next k
        gap = gap / 3
    Wend
End Sub

最初はクイックソートを使用していたのですが,小説をまるごと貼り付けると, Word VBAのスタックをあっという間に使い尽くしてしまったため,シェルソートに 変更してあります。23万語くらいまでは試しましたが,ソートまできちんとできました。

例えば,『吾輩は猫である』の文章を貼り付け,ワードで分析するとこのように 表示されます。(結果を段組表示しています。)

WordCount.doc
(C) 2003- S.Dozono All Rights Reserved.
E-Mail: dozono@(at)gmail.com