! H05ABF Example Program Text
! Mark 30.3 Release. nAG Copyright 2024.
Module h05abfe_mod
! .. Use Statements ..
Use nag_library, Only: nag_wp
! .. Implicit None Statement ..
Implicit None
! .. Accessibility Statements ..
Private
Public :: f, prepare_user_arrays
! .. Parameters ..
Integer, Parameter, Public :: nin = 5, nout = 6
Contains
Subroutine f(m,drop,lz,z,la,a,score,iuser,ruser,info)
! Score calculating function required by H05ABF
! M,DROP,LZ,Z,LA,A,SCORE IUSER and RUSER are all as described in the
! documentation of H05ABF.
! This particular example finds the set, of a given size, of explanatory
! variables that best fit a response variable when a linear regression
! model is used. Therefore the feature set is the set of all the
! explanatory variables and the best set of features is defined as set
! of explanatory variables that gives the smallest residual sums of
! squares.
! See the documentation for G02DAF for details on linear regression
! models.
! .. Use Statements ..
Use nag_library, Only: g02daf
! .. Scalar Arguments ..
Integer, Intent (In) :: drop, la, lz, m
Integer, Intent (Inout) :: info
! .. Array Arguments ..
Real (Kind=nag_wp), Intent (Inout) :: ruser(*)
Real (Kind=nag_wp), Intent (Out) :: score(max(la,1))
Integer, Intent (In) :: a(la), z(lz)
Integer, Intent (Inout) :: iuser(*)
! .. Local Scalars ..
Real (Kind=nag_wp) :: rss, tol
Integer :: ex, ey, i, idf, ifail, inv_drop, ip, &
irank, ldq, ldx, n, sx, sy
Logical :: svd
Character (1) :: mean, weight
! .. Local Arrays ..
Real (Kind=nag_wp), Allocatable :: b(:), cov(:), h(:), p(:), q(:,:), &
res(:), se(:), wk(:), wt(:)
Integer, Allocatable :: isx(:)
! .. Intrinsic Procedures ..
Intrinsic :: abs, count, max
! .. Executable Statements ..
info = 0
n = iuser(1)
ldq = n
ldx = n
! No intercept term and no weights
mean = 'Z'
weight = 'U'
! Allocate various arrays required by G02DAF
Allocate (b(m),cov((m*m+m)/2),h(n),p(m*(m+2)),q(ldq,m+1),res(n),se(m), &
wk(m*m+5*(m-1)),wt(1),isx(m))
! Set up the initial feature set. If DROP = 0, this is the Null set
! (i.e. no features). If DROP = 1 then this is the full set (i.e. all
! features)
isx(1:m) = drop
! Add (if DROP = 0) or remove (if DROP = 1) the all the features
! specified in Z
inv_drop = abs(drop-1)
Do i = 1, lz
isx(z(i)) = inv_drop
End Do
! Get the start and end of X and Y in RUSER
sx = iuser(4)
ex = sx + m*n - 1
sy = iuser(3)
ey = sy + n - 1
! Extract some parameters from RUSER
tol = ruser(iuser(2))
Do i = 1, max(la,1)
If (la>0) Then
If (i>1) Then
! Reset the feature altered at the last iteration
isx(a(i-1)) = drop
End If
! Add or drop the I'th feature in A
isx(a(i)) = inv_drop
End If
ip = count(isx(1:m)==1)
! Fit the regression model
ifail = 0
Call g02daf(mean,weight,n,ruser(sx:ex),ldx,m,isx,ip,ruser(sy:ey),wt, &
rss,idf,b,se,cov,res,h,q,ldq,svd,irank,p,tol,wk,ifail)
! Return the score (the residual sums of squares)
score(i) = rss
End Do
! Keep track of the number of subsets evaluated
iuser(5) = iuser(5) + max(1,la)
End Subroutine f
Subroutine prepare_user_arrays(m,iuser,ruser)
! Populate the user arrays
! M is the maximum number of features (as per H05ABF)
! In this example RUSER holds the data required for the linear
! regression (the matrix of explanatory variables, X, the vector of
! response values, Y, and the tolerance, TOL) and IUSER holds number
! of observations and the location of the various elements in RUSER
! .. Scalar Arguments ..
Integer, Intent (In) :: m
! .. Array Arguments ..
Real (Kind=nag_wp), Allocatable, Intent (Out) :: ruser(:)
Integer, Allocatable, Intent (Out) :: iuser(:)
! .. Local Scalars ..
Integer :: i, ierr, j, liuser, lruser, n, p1, &
p2
Character (200) :: line
! .. Executable Statements ..
! Read in the number of observations for the data used in the linear
! regression skipping any headings or blank lines
Do
Read (nin,*,Iostat=ierr) line
If (ierr/=0) Then
Exit
End If
Read (line,*,Iostat=ierr) n
If (ierr==0) Then
Exit
End If
End Do
! Allocate space for the user arrays
liuser = 5
lruser = n + n*m + 1
Allocate (ruser(lruser),iuser(liuser))
! Number of observations
iuser(1) = n
! Location of TOL in RUSER
iuser(2) = 1
! Start of Y in RUSER
iuser(3) = 2
! Start of X in RUSER
iuser(4) = iuser(3) + n
! Keep track of the number of subsets evaluated
iuser(5) = 0
! Read in the tolerance for the regression
Read (nin,*) ruser(iuser(2))
! Read in the data
p1 = iuser(3)
p2 = iuser(4)
Do i = 0, n - 1
Read (nin,*)(ruser(p2+i+j*n),j=0,m-1), ruser(p1+i)
End Do
End Subroutine prepare_user_arrays
End Module h05abfe_mod
Program h05abfe
! .. Use Statements ..
Use h05abfe_mod, Only: f, nin, nout, prepare_user_arrays
Use nag_library, Only: h05abf, nag_wp
! .. Implicit None Statement ..
Implicit None
! .. Local Scalars ..
Real (Kind=nag_wp) :: gamma
Integer :: i, ifail, ip, j, la, m, mincnt, &
mincr, mip, nbest
! .. Local Arrays ..
Real (Kind=nag_wp) :: acc(2)
Real (Kind=nag_wp), Allocatable :: bscore(:), ruser(:)
Integer, Allocatable :: a(:), bz(:,:), ibz(:), iuser(:), &
z(:)
Logical, Allocatable :: mask(:)
! .. Intrinsic Procedures ..
Intrinsic :: max, pack
! .. Executable Statements ..
Write (nout,*) 'H05ABF Example Program Results'
Write (nout,*)
! Skip headings in data file
Read (nin,*)
Read (nin,*)
! Read in the problem size
Read (nin,*) m, ip, nbest
! Read in the control parameters for the subset selection
Read (nin,*) mincr, mincnt, gamma, acc(1:2)
! Allocate memory required by the subset selection routine
mip = m - ip
Allocate (z(mip),a(max(nbest,m)),bz(mip,nbest),bscore(max(nbest,m)))
! Prepare the user workspace arrays IUSER and RUSER
Call prepare_user_arrays(m,iuser,ruser)
! Call the forward communication best subset routine
ifail = -1
Call h05abf(mincr,m,ip,nbest,la,bscore,bz,f,mincnt,gamma,acc,iuser, &
ruser,ifail)
If (ifail/=0 .And. ifail/=42) Then
! An error occurred
Go To 100
End If
! Titles
Write (nout,99999) ' Score Feature Subset'
Write (nout,99999) ' ----- --------------'
! Display the best subsets and corresponding scores. H05AAF returns a list
! of features excluded from the best subsets, so this is inverted to give
! the set of features included in each subset
Allocate (ibz(m),mask(m))
ibz(1:m) = (/(i,i=1,m)/)
Do i = 1, la
mask(1:m) = .True.
Do j = 1, mip
mask(bz(j,i)) = .False.
End Do
Write (nout,99998) bscore(i), pack(ibz,mask)
End Do
Write (nout,*)
If (ifail==42) Then
Write (nout,99997) nbest, &
' subsets of the requested size do not exist, only ', la, &
' are displayed.'
End If
Write (nout,99996) iuser(5), ' subsets evaluated in total'
100 Continue
99999 Format (1X,A)
99998 Format (1X,E12.5,100(1X,I5))
99997 Format (1X,I0,A,I0,A)
99996 Format (1X,I0,A)
End Program h05abfe