Skip to content

Instantly share code, notes, and snippets.

@takkkun

takkkun/gist:824593

Created February 13, 2011 11:10
Show Gist options
  • Save takkkun/824593 to your computer and use it in GitHub Desktop.
Save takkkun/824593 to your computer and use it in GitHub Desktop.
Download ZIP
Raw
gistfile1.bas
VERSION 5.00
Begin VB.Form frmMain
BorderStyle = 1 '固定(実線)
Caption = "相関係数・回帰直線"
ClientHeight = 6135
ClientLeft = 45
ClientTop = 330
ClientWidth = 4695
BeginProperty Font
Name = "BDF M+"
Size = 9
Charset = 128
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 6135
ScaleWidth = 4695
StartUpPosition = 3 'Windows の既定値
Begin VB.CommandButton cmdPrintData
Caption = "描画"
Height = 255
Left = 3240
TabIndex = 5
Top = 5760
Width = 1335
End
Begin VB.CommandButton cmdCalculateData
Caption = "計算"
Height = 255
Left = 1680
TabIndex = 4
Top = 5760
Width = 1335
End
Begin VB.TextBox txtFileName_2
Height = 285
Left = 120
TabIndex = 3
Text = "txtFileName_2"
Top = 5400
Width = 4455
End
Begin VB.TextBox txtFileName_1
Height = 285
Left = 120
TabIndex = 2
Text = "txtFileName_1"
Top = 5040
Width = 4455
End
Begin VB.PictureBox picScreen
AutoRedraw = -1 'True
Height = 4455
Left = 120
ScaleHeight = 1000
ScaleMode = 0 'ﾕｰｻﾞｰ
ScaleWidth = 1000
TabIndex = 1
Top = 120
Width = 4455
End
Begin VB.CommandButton cmdLoadFile
Caption = "読み込み"
Height = 255
Left = 120
TabIndex = 0
Top = 5760
Width = 1335
End
Begin VB.Label lblPrint
Caption = "lblPrint"
Height = 255
Left = 120
TabIndex = 6
Top = 4680
Width = 4455
End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'------------------------------------------------------------------------------------------
'名　称：相関係数・回帰直線計算プログラム
'作成者：n-Wisteria
'作成日：2004/04/05
'更新日：2004/04/05
'------------------------------------------------------------------------------------------
'変数の宣言を強制する
Option Explicit
'配列の要素を１から開始する
Option Base 1
'変数の宣言
Private m_arrXValues(100) As Integer 'データＸ
Private m_arrYValues(100) As Integer 'データＹ
Private m_dblCC As Double '相関係数
Private m_dblStartPos As Double '回帰直線・Ｙ座標始点
Private m_dblEndPos As Double '回帰直線・Ｙ座標終点
Private m_intDataCount As Integer 'データの個数
Private m_intCode As Integer '符号
Private Sub cmdLoadFile_Click()
'変数の宣言
Dim strFilePath_1 As String 'ファイルパス１
Dim strFIlePath_2 As String 'ファイルパス２
Dim i As Integer 'カウンタ
'コントロールと変数の初期化
m_dblCC = 0
m_dblStartPos = 0
m_dblEndPos = 0
m_intDataCount = 0
lblPrint.Caption = "相関係数：計算されていません"
'ファイルパスの格納
strFilePath_1 = App.Path & "\" & txtFileName_1.Text & ".txt"
strFIlePath_2 = App.Path & "\" & txtFileName_2.Text & ".txt"
'ファイル有無のチェック
If Dir(strFilePath_1) = "" Then
MsgBox ("[ " & strFilePath_1 & " ] が見つかりません")
Exit Sub
End If
If Dir(strFIlePath_2) = "" Then
MsgBox ("[ " & strFIlePath_2 & " ] が見つかりません")
Exit Sub
End If
'データを配列に格納
Open strFilePath_1 For Input As #1: Open strFIlePath_2 For Input As #2
For i = 1 To 100
If EOF(1) Or EOF(2) Then Exit For
Input #1, m_arrXValues(i)
Input #2, m_arrYValues(i)
Next i
Close #1, #2
'データ件数を格納
m_intDataCount = i - 1
'読み込みデータ件数の確認
MsgBox ("X,Y それぞれに" & m_intDataCount & "件のデータが読み込まれました")
End Sub
Private Sub cmdCalculateData_Click()
'変数の宣言
Dim dblXAverage As Double 'データＸの平均値
Dim dblYAverage As Double 'データＹの平均値
Dim dblSxx As Double 'データＳｘｘ
Dim dblSyy As Double 'データＳｙｙ
Dim dblSxy As Double 'データＳｘｙ
Dim i As Integer 'カウンタ
'データ件数のチェック
If m_intDataCount = 0 Then
MsgBox ("データ件数が0件では計算できません")
Exit Sub
End If
'平均値の計算
dblXAverage = Average("X")
dblYAverage = Average("Y")
'Sxx, Syy, Sxy の計算
dblSxx = CalcS("xx", dblXAverage, 0)
dblSyy = CalcS("yy", 0, dblYAverage)
dblSxy = CalcS("xy", dblXAverage, dblYAverage)
'相関係数の計算
m_dblCC = dblSxy / Sqr(dblSxx * dblSyy)
'回帰直線の計算
m_dblStartPos = dblYAverage - dblSxy / dblSxx * dblXAverage
m_dblEndPos = dblSxy / dblSxx * 1000 + m_dblStartPos
If dblSxy / dblSxx > 0 Then
m_intCode = 1
Else
m_intCode = -1
End If
'計算完了の確認
lblPrint.Caption = "相関係数：計算完了"
End Sub
Private Sub cmdPrintData_Click()
'変数の宣言
Dim intXMax As Integer 'データＸの最大値
Dim intYMax As Integer 'データＹの最大値
Dim i As Integer 'カウンタ
'相関係数の表示
lblPrint.Caption = "相関係数：" & m_dblCC
'目盛りの表示
'略
'最大値の取得
intXMax = Max("X") + 5
intYMax = Max("Y") + 5
'データの座標のプロット
picScreen.Cls
picScreen.DrawWidth = 2
For i = 1 To m_intDataCount
picScreen.PSet (m_arrXValues(i) / intXMax * 500 + 500, m_arrYValues(i) / intYMax * 500 + 500)
Next i
'回帰直線の表示
picScreen.DrawWidth = 1
picScreen.Line (500, m_dblStartPos + 500)-(1000 * m_intCode, m_dblEndPos + 500), vbRed
End Sub
Private Function Average(ByVal Style As String) As Double
'変数の宣言
Dim lngTotal As Long '合計値
Dim i As Integer 'カウンタ
'合計値の初期化
lngTotal = 0
'区分によって処理を分岐
Select Case Style
Case "X"
For i = 1 To m_intDataCount
lngTotal = lngTotal + m_arrXValues(i)
Next i
Case "Y"
For i = 1 To m_intDataCount
lngTotal = lngTotal + m_arrYValues(i)
Next i
Case Else
'何も処理しない
End Select
'平均値を返す
Average = lngTotal / m_intDataCount
End Function
Private Function Max(ByVal Style As String) As Integer
'変数の宣言
Dim intMax As Integer '最大値
Dim i As Integer 'カウンタ
'最大値の初期化
intMax = 0
'区分によって処理を分岐
Select Case Style
Case "X"
For i = 1 To m_intDataCount
If m_arrXValues(i) > intMax Then intMax = m_arrXValues(i)
Next i
Case "Y"
For i = 1 To m_intDataCount
If m_arrYValues(i) > intMax Then intMax = m_arrYValues(i)
Next i
Case Else
'何も処理しない
End Select
'最大値を返す
Max = intMax
End Function
Private Function CalcS(ByVal Style As String, ByVal XAverage As Double, ByVal YAverage As Double) As Double
'変数の宣言
Dim dblTotal As Double '合計値
Dim i As Integer 'カウンタ
'合計値の初期化
dblTotal = 0
'区分によって処理を分岐
Select Case Style
Case "xx"
For i = 1 To m_intDataCount
dblTotal = dblTotal + (m_arrXValues(i) - XAverage) ^ 2
Next i
Case "yy"
For i = 1 To m_intDataCount
dblTotal = dblTotal + (m_arrYValues(i) - YAverage) ^ 2
Next i
Case "xy"
For i = 1 To m_intDataCount
dblTotal = dblTotal + (m_arrXValues(i) - XAverage) * (m_arrYValues(i) - YAverage)
Next i
Case Else
'何も処理しない
End Select
'値を返す
CalcS = dblTotal
End Function
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment