Lunatical life in broad daylight
へにょ~~~…… リ ツ 。ヮ ツ。
スポンサーサイト
上記の広告は1ヶ月以上更新のないブログに表示されています。
新しい記事を書く事で広告が消せます。
Dean―DixonのQ検定マクロコード(ExcelVBA)
131110-02.jpg

ノリ ーヮール 「とうとう、本業ネタまで引っ張りだしましたか……」
ッリ ;・ヮ・)ッ 「だって、最近は実験忙しくて、疲れきって帰ってからは艦これしかやってないんだもん。実験関係で機密にしなくてもいいことって言ったら、これくらいのものだよぉ」
ノリ ・ヮ⌒ル 「QテストはDean-Dixonによって考えられた手法です。測定数が少ないデータの中に、1つだけ他の測定値よりも大きく外れたものがあったとき、その外れたデータを拾うべきか棄てるべきか判定することができます」
ッリ ⌒ヮ⌒)ッ 「統計学的に根拠がある方法だから、測定数が少ない時にも有効なのが魅力だよぉ。データ数が2以下だと使えないのが難点だけど、誤差率が異常に高くて迷った時には役に立つと思うよぉ」
ノリ ーヮール 「データ数10個までしか対応していませんけどね」
ッリ ;・ヮ・)ッ 「だって、判定に使う棄却係数の文献値が、データ数3~10個の場合までしか載ってなかったんだもん」
ノリ ・ヮ・ル 「そもそも、11回以上の測定が可能な環境であれば、こんな判定法に頼る必要はありませんからね」
ッリ川・ヮ・)ッ「使う対象にしていた装置での測定回数が、最大で5回だったこともあるから、そこは見逃してね」
ノリ ⌒ヮ⌒ル「データ解析と誤差の扱いに迷える子羊さんたちの一助になれば幸いです。ファイルを直接ダウンロードしたい方は新築した物置から、コードを観察したりコピペしたい方は、『続きを読む』に追記しておきましたのでそれをご参照ください」

【追記:すずっちのお手製コード】

ッリ ・ヮ・)ッ 「というわけで、すずっちの書いたマクロコードだよぉ」
ノリ ーヮール 「ソート部分は、Excel先生による自動記録ですよね」
ッリ ・ヮ・)ッ・:*:・ (ぐふっ!!)
ノリ ;・ヮ・ル「第一印象としては……美しさに欠けるコードですね」
ッリ川・ヮ・)ッ 「VBL初心者なんだから仕方ないよぉ。すずっちSEじゃなくて化学屋さんなんだから、とりあえず動けばいいんだもんっ!?」
ノリ ・ヮ⌒ル「データ列に入れる数値は自動でソートするようにしてありますので、適当に上の行から入力してOKです」
ッリ`・ヮ・´)ッ 「下で公開しているのは、棄却係数Qを定数にして90%信頼限界で検定するコードだよぉ。シートごとに信頼限界95%や99%にも拡張したVer.2も公開しているけれど、定数定義部分に入れている数値を、この文献から持ってきて書き替えたものだから、基本的にはほとんど変わっていないよぉ」



Sub Q検定法()
'
' Q検定法 Macro
' データを大きい順に並べかえ、疑わしい数値とその隣との差(a)を
'最大値と最小値の差(w)で割ったQ比を、90%信頼限界におけるQ値と
'比較。棄却可能かどうかを判定する (データ数は10個まで対応)
'
' Keyboard Shortcut: Ctrl+q
'

'検定を行う前に、以前の操作の出力内容を消去する
Range("B5:E14").ClearContents

'定義部分
'90%信頼限界における棄却係数Qを、あらかじめ定義
Const Q3 As String = 0.94
Const Q4 As String = 0.76
Const Q5 As String = 0.64
Const Q6 As String = 0.56
Const Q7 As String = 0.51
Const Q8 As String = 0.47
Const Q9 As String = 0.44
Const Q10 As String = 0.41

'マクロで処理するデータ数(=行数)を決定する
Dim n As Single
n = Cells(2, 2).Value

'入力されたデータ数をもとに、判定に用いるQ値を決定。セルに入力する
If n = 3 Then
Cells(5, 4).Value = Q3
Cells(n + 4, 4).Value = Q3
End If

If n = 4 Then
Cells(5, 4).Value = Q4
Cells(n + 4, 4).Value = Q4
End If

If n = 5 Then
Cells(5, 4).Value = Q5
Cells(n + 4, 4).Value = Q5
End If

If n = 6 Then
Cells(5, 4).Value = Q6
Cells(n + 4, 4).Value = Q6
End If

If n = 7 Then
Cells(5, 4).Value = Q7
Cells(n + 4, 4).Value = Q7
End If

If n = 8 Then
Cells(5, 4).Value = Q8
Cells(n + 4, 4).Value = Q8
End If

If n = 9 Then
Cells(5, 4).Value = Q9
Cells(n + 4, 4).Value = Q9
End If

If n = 10 Then
Cells(5, 4).Value = Q10
Cells(n + 4, 4).Value = Q10
End If

'セルに入力された値を取り込んで、今回の判定に用いる棄却係数Qとする
Dim testQ As Single
testQ = Cells(5, 4).Value

' 降順ソートを行う
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("A5"), _
SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet1").Sort
.SetRange Range("A5:A14")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

'最大値を取り込む
Dim Max As Single
Max = Cells(5, 1).Value

'最大値の隣接値を取り込む
Dim subMax As Single
subMax = Cells(6, 1).Value

'最小値を取り込む
Dim Min As Single
Min = Cells(n + 4, 1).Value

'最小値の隣接値を取り込む
Dim subMin As Single
subMin = Cells(n + 3, 1).Value

'最大値と隣接値との差を求める
Dim difMax As Single
difMax = Max - subMax

'最小値と隣接値との差を求める
Dim difMin As Single
difMin = subMin - Min

'全データの範囲 wide を求め、最大値と最小値に隣接するセルに入力する
Dim wide As Single
wide = Max - Min
Cells(5, 2).Value = wide
Cells(n + 4, 2).Value = wide

'最大値のQ比を求め、セルに入力する
Dim Qratio_Max As Single
Qratio_Max = difMax / wide
Cells(5, 3).Value = Qratio_Max

'最小値のQ比を求め、セルに入力する
Dim Qratio_Min As Single
Qratio_Min = difMin / wide
Cells(n + 4, 3).Value = Qratio_Min

'最大値のQ比を棄却係数Qと比較して、Q比が棄却係数以上であれば、棄却する。
If Qratio_Max < testQ Then
Cells(5, 5).Value = "棄却不可"
Else:
Cells(5, 5).Value = "棄却"
End If

'最小値のQ比を棄却係数Qと比較して、Q比が棄却係数以上であれば、棄却する。
If Qratio_Min < testQ Then
Cells(n + 4, 5).Value = "棄却不可"
Else:
Cells(n + 4, 5).Value = "棄却"
End If

End Sub




コメント
▼この記事へのコメント<(あれば表示)
すずっちすげー!
チャレンジポイントの各クレの記録とかこれに入れてみたいですね!
2013/11/12(火) 13:56:42 | URL | byベラミ (#-) [ 編集]
 コメントありですー♪

 そうですね……基本、正規分布であることを前提にして
『同じグループの個体とみなせるのか』を検定するツール
ですから、スコア・行脚店舗数・クリアレートなど、いろいろな
数値を入力で遊ぶことができそうですねw

 チャレンジポイントの場合は、「調子が別人のように良い
のか or 悪いのか」を判定できると思いますw
2013/11/17(日) 10:59:24 | URL | byすずっち (#BhkiWIsU) [ 編集]

■ コメントを投稿する
URL:
Comment:
Pass:
秘密: 管理者にだけ表示を許可する
 
トラックバック
この記事のトラックバックURL

▼この記事へのトラックバック(あれば表示)
上記広告は1ヶ月以上更新のないブログに表示されています。新しい記事を書くことで広告を消せます。