home *** CD-ROM | disk | FTP | other *** search
/ Media Share 9 / MEDIASHARE_09.ISO / progmisc / dblib201.zip / STATS.PRG < prev    next >
Text File  |  1993-02-25  |  39KB  |  949 lines
  1. *-------------------------------------------------------------------------------
  2. *-- Program...: STATS.PRG
  3. *-- Programmer: Ken Mayer (CIS: 71333,1030) and Jay Parsons (CIS: 70160,340)
  4. *-- Date......: 02/23/1993
  5. *-- Notes.....: Statistical Functions -- see README.TXT to include this 
  6. *--             library file in your system.
  7. *-------------------------------------------------------------------------------
  8.  
  9. FUNCTION Samplevar
  10. *-------------------------------------------------------------------------------
  11. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  12. *-- Date........: 04/13/1992
  13. *-- Notes.......: Finds sample variance of specified field of the current
  14. *--             : database, using CALCULATE command.
  15. *--             : The CALCULATE command calculates the population variance,
  16. *--             : which is smaller by a factor of (n-1)/n.
  17. *--             :
  18. *-- Written for.: dBASE IV Version 1.5
  19. *-- Rev. History: Original function 1990.
  20. *--             : Modified to take optional parameter, 4/13/1992
  21. *-- Calls       : None
  22. *-- Called by...: Any
  23. *-- Usage.......: Samplevar( <cField> [, <cClause> ] )
  24. *-- Example.....: ? Samplevar( "Balance", ".FOR..NOT. isblank( Balance )" )
  25. *-- Returns     : a numeric or float value, the sample variance, or .F. if
  26. *--             : it cannot be calculated.
  27. *--             : If any of the numeric items are floats, the result will be.
  28. *-- Parameters..: cField, name of a numeric field of the current database
  29. *--             : for which to calculate the sample variance
  30. *--             : cClause, optional, a FOR, WHILE, TO, etc. clause
  31. *-------------------------------------------------------------------------------
  32.    PARAMETERS cField, cCondition
  33.    PRIVATE fVar, nCount, cCond
  34.    IF pcount() = 2
  35.       cCond = " "+ cCondition
  36.    ELSE
  37.       cCond = ""
  38.    ENDIF
  39.    CALCULATE VAR( &cField ), CNT() TO fVar, nCount &cCond
  40.  
  41. RETURN iif( nCount > 1, fVar * nCount / ( nCount - 1 ), .F. )
  42. *-- Eof: Samplevar()
  43.  
  44. FUNCTION Stny
  45. *-------------------------------------------------------------------------------
  46. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  47. *-- Date........: 11/13/1990
  48. *-- Notes.......: Returns value of the standard normal distribution function
  49. *--             : given a number of standard deviations from the mean.
  50. *--             : This function is not useful alone.  The standard normal
  51. *--             : distribution function is the familiar bell-shaped curve
  52. *--             : scaled so its mean is at 0, each standard deviation is 1
  53. *--             : and the total area under the curve is 1.  The function
  54. *--             : Stnarea calls on this function to calculate the approximate
  55. *--             : area (a fraction equal to percent of the total) under the
  56. *--             : part of the curve lying betwen the mean and the given
  57. *--             : number of standard deviations.
  58. *--             :
  59. *-- Written for.: dBASE IV
  60. *-- Rev. History: 11/13/1990 -- Original Release
  61. *-- Calls       : None
  62. *-- Called by...: Any
  63. *-- Usage.......: Stny( <nDevs> )
  64. *-- Example.....: ? Stny( 1 )
  65. *-- Returns     : numeric value of the function.
  66. *-- Parameters..: nDevs, standard deviations from the mean
  67. *-------------------------------------------------------------------------------
  68.    PARAMETERS nDevs
  69.  
  70. RETURN exp( -nDevs * nDevs / 2 ) / sqrt( 2 * pi() )
  71. *-- EoF: Stny()
  72.  
  73. FUNCTION Stnarea
  74. *-------------------------------------------------------------------------------
  75. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  76. *-- Date........: 11/13/1990
  77. *-- Notes.......: Area of the standard normal distribution function between
  78. *--             : mean and given number of standard deviations from the mean.
  79. *--             :
  80. *--             : What's it about?  Well, College Board scores (originally)
  81. *--             : were based on a normal distribution with a mean of 500 and
  82. *--             : 100 points per standard deviation.  Knowing that a 650
  83. *--             : score is 1.5 standard deviations from the 500 mean, we
  84. *--             : can calculate Stnarea( 1.5 ) as .4332.  This tells us that
  85. *--             : 43.32% of the scores lie between 650 and 500.  Since 50%
  86. *--             : lie below 500, a score of 650 beats 93.32% of the scores.
  87. *--             :
  88. *--             : The polynomial approximation used by this function is said
  89. *--             : to be accurate to .00001, 1/1000 of one percent.  Remember
  90. *--             : to SET DECIMALS appropriately to view results.
  91. *--             :
  92. *-- Written for.: dBASE IV
  93. *-- Rev. History: 11/13/1990 -- Original Release
  94. *-- Calls       : Stny()            Function in STATS.PRG
  95. *-- Called by...: Any
  96. *-- Usage.......: Stnarea( <nDevs> )
  97. *-- Example.....: ? Stnarea( 1.5 )
  98. *-- Returns     : % of area between deviations given and the mean, 0<=a<.5.
  99. *-- Parameters..: nDevs, standard deviations from the mean
  100. *-------------------------------------------------------------------------------
  101.    PARAMETERS nDevs
  102.    PRIVATE nX, nV
  103.    nX = abs( nDevs )
  104.    nV =  1 / ( 1 + .33267 * nX )
  105.  
  106. RETURN .5 - Stny( nX ) * ( .4361836  * nV - .1201676 * nV * nV ;
  107.      + .937298 * nV * nV * nV )
  108. *-- EoF: Stnarea()
  109.  
  110. FUNCTION Stnz
  111. *-------------------------------------------------------------------------------
  112. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  113. *-- Date........: 11/13/1990
  114. *-- Notes.......: A lookup table to find the values of "z", standard
  115. *--             : deviations, corresponding to the most common areas inside a
  116. *--             : given number of tails of the normal distribution function.
  117. *--             :
  118. *--             : Used in testing confidence intervals.  If a sample of
  119. *--             : light bulbs from a shipment shows an average life of 1150
  120. *--             : hours, and the criterion for rejection of the shipment is
  121. *--             : 95% confidence that the average life of all bulbs is less
  122. *--             : than (a single tail) 1200 hours, the value 1.64485 returned
  123. *--             : by this function is necessary to determine whether to
  124. *--             : reject the shipment or not.
  125. *--             :
  126. *--             : Values of "z" that are not found in the table can be found
  127. *--             : using Stndevs, below, but it is slow.
  128. *--             :
  129. *-- Written for.: dBASE IV
  130. *-- Rev. History: 11/13/1990 -- Original Release
  131. *-- Calls       : None
  132. *-- Called by...: Any
  133. *-- Usage.......: Stnz( <nProb>, <nTails> )
  134. *-- Example.....: ? Stnz( .95, 1 )
  135. *-- Returns     : z, number of standard deviations from mean inside which
  136. *--             : ( or to the side of which includes the mean, if one tail)
  137. *--             : the given percentage of area will fall.
  138. *--             : Returns -1 if no entry in table.
  139. *-- Parameters..: nConf, confidence desired, 0 < nConf < 1
  140. *--             : nTails, 1 or 2 = number of tails of curve of interest
  141. *-------------------------------------------------------------------------------
  142.    PARAMETERS nConf, nTails
  143.    IF nTails # 1 .AND. nTails # 2
  144.       RETURN -1
  145.    ENDIF
  146.    DO CASE
  147.       CASE nConf = .95
  148.          RETURN iif( nTails = 1, 1.64485, 1.96010 )
  149.       CASE nConf = .99
  150.          RETURN iif( nTails = 1, 2.32676, 2.57648 )
  151.       CASE nConf = .995
  152.          RETURN iif( nTails = 1, 2.57648, 2.80794 )
  153.       CASE nConf = .999
  154.          RETURN iif( nTails = 1, 3.09147, 3.29202 )
  155.       OTHERWISE
  156.          RETURN -1
  157.    ENDCASE
  158.  
  159. *-- EoF: Stnz()
  160.  
  161. FUNCTION Stndiff
  162. *-------------------------------------------------------------------------------
  163. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  164. *-- Date........: 04/13/1992
  165. *-- Notes.......: Determines whether hypothesis that sample of a given mean
  166. *--               is different from expected mean is justified.
  167. *--
  168. *--               If nPopstd, the standard deviation of the population, is
  169. *--               not known and nSample, the sample size, is greater than
  170. *--               30, the sample standard deviation may be used for nPopstd.
  171. *--
  172. *--               This function assumes the population is large relative to
  173. *--               the sample or that the sampling is with replacement.  If
  174. *--               neither is true, the right side of the expression in the
  175. *--               later return line should be multiplied by:
  176. *--                     sqrt( ( nPop - nSample ) / ( nPop - 1 ) )
  177. *--               where nPop is the size of the population.
  178. *--
  179. *--               Do not use this with small samples, less than 20, because
  180. *--               the standard normal distribution is not sufficiently
  181. *--               accurate as an approximation of the distribution of sample
  182. *--               means in such a case.  See "Student's T-distribution" in a
  183. *--               statistics text.
  184. *--
  185. *-- Written for.: dBASE IV Version 1.5
  186. *-- Rev. History: 04/13/1992 -- Original Release
  187. *-- Calls       : Stnz()            Function in STATS.PRG
  188. *-- Called by...: Any
  189. *-- Usage.......: Stndiff( <nConf>, <nTails>, <nSample>, <nSampmean>, ;
  190. *--             :    <nPopmean>, <nPopstd> )
  191. *-- Example.....: ? Stndiff( .95, 1, 30, 1150, 1200, 20 )
  192. *-- Returns     : .T. if hypothesis of difference is justified to degree of
  193. *--             : confidence specified, or .F.  Returns -1 if confidence is
  194. *--             : not one for which z can be looked up in Stnz().  If you
  195. *--             : need other confidence levels, run Stndevs() to find the
  196. *--             : z values for them and add them to the Stnz() table.
  197. *-- Parameters..: nConf, confidence desired, 0 < nConf < 1
  198. *--             : nTails, 1 or 2 = number of tails of curve of interest
  199. *--             : nSample, number of items in the sample
  200. *--             : nSampmean, mean of the sample
  201. *--             : nPopmean, mean of the population ( test standard mean )
  202. *--             : nPopstd, standard deviation of population
  203. *-------------------------------------------------------------------------------
  204.    PARAMETERS nConf, nTails, nSample, nSampmean, ;
  205.               nPopmean, nPopstd
  206.    PRIVATE nStd
  207.    nStd = Stnz( nConf, nTails )
  208.    IF nStd = -1
  209.       RETURN nStd
  210.    ELSE
  211.       RETURN abs( nSampmean - nPopmean ) ;
  212.                  > nStd * nPopstd / sqrt( nSample )
  213.    ENDIF
  214. *-- EoF: Stndiff()
  215.  
  216. FUNCTION Stndevs
  217. *-------------------------------------------------------------------------------
  218. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  219. *-- Date........: 04/13/1992
  220. *-- Notes.......: Calculates "z", standard deviations, corresponding to any
  221. *--             : area of standard normal curve between mean and the desired
  222. *--             : z. Much slower than Stnz().
  223. *-- Written for.: dBASE IV Version 1.5
  224. *-- Rev. History: Original function 1990.
  225. *--             : Conformed to Zeroin() 4/13/1992.
  226. *-- Calls       : Zeroin()          Function in STATS.PRG 
  227. *-- Called by...: Any
  228. *-- Usage.......: Stndevs( <nArea> )
  229. *-- Example.....: ? Stndevs( .96 )
  230. *-- Returns     : z, number of standard deviations from mean, or a negative
  231. *--             : number indicating failure to find a root..
  232. *-- Parameters..: nArea, area "left" of point of interest, .5 < nArea < 1
  233. *-------------------------------------------------------------------------------
  234.    PARAMETERS nArea
  235.    PRIVATE nTest, nFlag
  236.    IF nArea > .99999 .OR. nArea < .5
  237.       RETURN -1
  238.    ENDIF
  239.    nFlag = 0
  240.    nTest = Zeroin( "Tstnarea", 0, 4.2, float(1/100000), 100, nFlag, nArea )
  241.  
  242. RETURN iif( nFlag < 3, nTest, -nFlag )
  243. *-- EoF: Stndevs()
  244.  
  245. FUNCTION Tstnarea
  246. *-------------------------------------------------------------------------------
  247. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  248. *-- Date........: 11/13/1990
  249. *-- Notes.......: Translation function to convert area to left of point
  250. *--             : under standard normal curve to 0 for Zeroin().
  251. *-- Written for.: dBASE IV
  252. *-- Rev. History: 11/13/1990 -- Original Release
  253. *-- Calls       : Stnarea()         Function in STATS.PRG
  254. *-- Called by...: Any
  255. *-- Usage.......: Tstnarea( <nDevs>, <nArea> )
  256. *-- Example.....: ? Tstnarea( 1.6,.96 )
  257. *-- Returns     : positive or negative number corresponding to direction to
  258. *--             : root where nArea = Stnarea
  259. *-- Parameters..: nDevs, trial number of standard deviations
  260. *--             : nArea, area for which deviations are to be found
  261. *-------------------------------------------------------------------------------
  262.    PARAMETERS nDevs, nArea
  263.  
  264. RETURN Stnarea( nDevs ) +.5 - nArea
  265. *-- EoF: Tstnarea()
  266.  
  267. FUNCTION Zeroin
  268. *-------------------------------------------------------------------------------
  269. *-- Programmer..: Tony Lima (CIS: 72331,3724) and Jay Parsons (CIS: 70160,340)
  270. *-- Date........: 04/13/1992
  271. *-- Notes.......: Finds a zero of a continuous function.
  272. *--             : In substance, what this function does is close in on a
  273. *--             : solution to a function that cannot otherwise be solved.
  274. *--             : Assuming Y = f(X), if Y1 and Y2, the values of the function
  275. *--             : for X1 and X2, have different signs, there must be at least
  276. *--             : one value of X between X1 and X2 for which Y = 0, if the
  277. *--             : function is continuous.  This function closes in on such a
  278. *--             : value of X by a trial-and-error process.
  279. *--             :
  280. *--             : This function is very slow, so a maximum number of iterations
  281. *--             : is passed as a parameter.  If the number of iterations is
  282. *--             : exceeded, the function will fail to find a root.  If this
  283. *--             : occurs, pick different original "X" values, increase the
  284. *--             : number of iterations or increase the errors allowed.  Once
  285. *--             : an approximate root is found, you can use values of X close
  286. *--             : on either side and reduce the error allowed to find an
  287. *--             : improved solution.  Also, of course, the signs of Y must be
  288. *--             : different for the starting X values for the function to
  289. *--             : proceed at all.
  290. *--             :
  291. *--             : NOTE ESPECIALLY - There is NO guarantee that a root returned
  292. *--             : by this function is the only one, or the most meaningful.
  293. *--             : It depends on the function that this function calls, but if
  294. *--             : that function has several roots, any of them may be returned.
  295. *--             : This can easily happen with such called functions as net
  296. *--             : present value where the cash flows alternate from positive
  297. *--             : to negative and back, and in many other "real life" cases.
  298. *--             : See the discussion of @IRR in the documentation of a good
  299. *--             : spreadsheet program such as Quattro Pro for further
  300. *--             : information.
  301. *--             :
  302. *--             : The method used by this function is a "secant and bisect"
  303. *--             : search.  The "secant" is the line connecting two X,Y
  304. *--             : points on a graph using standard Cartesian coordinates.
  305. *--             : Where the secant crosses the X axis is the best guess for
  306. *--             : the value of X that will have Y = 0, and will be correct
  307. *--             : if the function is linear between the two points.  The
  308. *--             : basic strategy is to calculate Y at that value of X, then
  309. *--             : keep the new X and that one of the old X values that had
  310. *--             : a Y-value of opposite sign, and reiterate to close in.
  311. *--             :
  312. *--             : If the function is a simple curve with most of the change
  313. *--             : in Y close to one of the X-values, as often occurs if the
  314. *--             : initial values of X are poorly chosen, repeated secants
  315. *--             : will do little to find a Y-value close to zero and will
  316. *--             : reduce the difference in X-values only slightly.  In this
  317. *--             : case the function shifts to choosing the new X halfway
  318. *--             : between the old ones, bisecting the difference and always
  319. *--             : reducing the bracket by half, for a while.
  320. *--             :
  321. *--             : While this function finds a "zero", it may be used to
  322. *--             : find an X corresponding to any other value of Y.  Suppose
  323. *--             : the function of X is FUNCTION Blackbox( X ) and it is
  324. *--             : desired to find a value of X for which f(X) = 7.  The trick
  325. *--             : is to interpose a function between Zeroin() and Blackbox()
  326. *--             : that will return a 0 to Zeroin() whenever Blackbox() returns
  327. *--             : 7.  By calling that function, Zeroin() finds a value of
  328. *--             : X for which Blackbox( X ) = 7, as required:
  329. *--             :    Result = Zeroin( "Temp", <other parameters omitted> )
  330. *--             :
  331. *--             :    FUNCTION Temp
  332. *--             :    parameters nQ
  333. *--             :    RETURN Blackbox( nQ ) - 7
  334. *--             :
  335. *-- Written for.: dBASE IV Version 1.5
  336. *-- Rev. History: Original function 1990.
  337. *--             : Modified to take optional parameters, 4/13/1992
  338. *-- Calls       : The function whose name is first parameter.
  339. *--             : NPV()             Function in FINANCE.PRG
  340. *-- Called by...: Any
  341. *-- Usage.......: Zeroin( <cFunction>, <fX1>, <fX2>, <fAbserror>, ;
  342. *--             :  <nMaxiter>, <n_Flag> ;
  343. *--             :  [, xPass1 [, xPass2 [, xPass3 ] ] ] )
  344. *-- Example.....: ? Zeroin( "Npv", 0, 200, .000001, 200, n_Flag, 11 )
  345. *-- Returns     : a float value representing a root, if n_Flag < 3.
  346. *-- Parameters..: cFunction, the name of the function to solve for a root.
  347. *--               fX1, one of the X-values between which the root is sought.
  348. *--               fX2, the second of these values.
  349. *--               Note: These MUST be chosen so the f( X ) values for the two
  350. *--               of them have opposite signs (they must bracket the result).
  351. *--               fAbserror, the absolute error allowed in the result.
  352. *--               nMaxiter, the maximum number of times to iterate.
  353. *--               n_Flag, an integer to signal success ( < 3 ) or failure.
  354. *--               xPass1 . . . 3, arguments to be passed through to cFunction.
  355. *--               The parameter "n_Flag" should be passed as a variable so it
  356. *--               may be accessed on return.  The limit of 9 literal parameters
  357. *--               may require passing others as variables.  The "xPass"
  358. *--               parameters are optional and the fact there are three of them
  359. *--               is arbitrary; they exist to hold whatever parameters may be
  360. *--               needed by the function cFunction being called aside from
  361. *--               the value of X for which it is being evaluated.  Add more
  362. *--               and change the 3 "&cFunc." lines below if you need more.
  363. *-- Side effects: Uses and alters a global numeric variable, here called
  364. *--               "n_Flag", to report error conditions resulting in value
  365. *--               returned being meaningless.  Possible n_Flag values are:
  366. *--                     1       success - root found within error allowed
  367. *--                     2       success - root was found exactly
  368. *--                     3       error   - function value not converging
  369. *--                     4       error   - original values do not bracket a root
  370. *--                     5       error   - maximum iterations exceeded
  371. *-------------------------------------------------------------------------------
  372.    parameters cFunc, fNearx, fFarx, fAbserr, nMaxiter, ;
  373.               n_Flag, xPass1, xPass2, xPass3
  374.    private nSplits, fBracket, fFary, fNeary, nIters
  375.    private fMaxabs, fOldx, fOldy, fDiffx, fAbsdiff, fSecant
  376.  
  377.    store 0 to nSplits, nIters
  378.    fBracket = abs ( fNearx - fFarx )
  379.    fFary = &cFunc.( fFarx, xPass1, xPass2, xPass3 )
  380.    fNeary = &cFunc.( fNearx, xPass1, xPass2, xPass3 )
  381.  
  382.    if sign( fNeary ) = sign( fFary )
  383.       n_Flag = 4
  384.       return float(0)
  385.    endif
  386.  
  387.    fMaxabs = max( abs( fNeary ), abs( fFary ) )
  388.    n_Flag = 0
  389.  
  390.    * Main iteration loop
  391.  
  392.    do while .t.
  393.  
  394.       if abs( fFary ) < abs( fNeary )
  395.  
  396.          * Interchange fNearx and fFarx so that
  397.          * fNearx is closer to a solution--
  398.          * abs( fNeary ) <= abs( fFary )
  399.  
  400.          fOldx  = fNearx
  401.          fOldy  = fNeary
  402.          fNearx = fFarx
  403.          fNeary = fFary
  404.          fFarx  = fOldx
  405.          fFary  = fOldy
  406.       endif
  407.  
  408.       fDiffx = fFarx - fNearx
  409.       fAbsdiff = abs( fDiffx )
  410.  
  411.       * Test whether interval is too small to continue
  412.  
  413.       if fAbsdiff <= 2 * fAbserr
  414.          if abs( fNeary ) > fMaxabs
  415.  
  416.             * Yes, but we are out of bounds
  417.  
  418.             n_Flag = 3
  419.             fNearx = float(0)
  420.          else
  421.  
  422.             * Yes, and we have a solution!
  423.  
  424.             n_Flag = 1
  425.          endif
  426.          exit
  427.       endif
  428.  
  429.       * Save the last approximation to x and y
  430.  
  431.       fOldx = fNearx
  432.       fOldy = fNeary
  433.  
  434.       * Check if reduction in the size of
  435.       * bracketing interval is satisfactory.
  436.       * If not, bisect until it is.
  437.  
  438.       nSplits = nSplits + 1
  439.       if nSplits >= 4
  440.          if 4 * fAbsdiff >= fBracket
  441.             fNearx = fNearx + fDiffx / 2
  442.          else
  443.             nSplits = 0
  444.             fBracket = fAbsdiff / 2
  445.  
  446.             * Calculate secant
  447.  
  448.             fSecant = ( fNearx - fFarx ) * fNeary ;
  449.                                / ( fFary - fNeary )
  450.  
  451.             * But not less than error allowed
  452.  
  453.             if abs( fSecant ) < fAbserr
  454.                fNearx = fnearx + fAbserr * sign( fDiffx )
  455.             else
  456.                fNearx = fNearx + fSecant
  457.             endif
  458.          endif
  459.       endif
  460.  
  461.       * Evaluate the function at the new approximation
  462.  
  463.       fNeary = &cFunc.( fNearx, xPass1, xPass2, xPass3 )
  464.  
  465.       * If it's exactly zero, we win!  Run with it
  466.  
  467.       if fNeary = 0.00
  468.          n_Flag = 2
  469.          exit
  470.       endif
  471.  
  472.       * Else adjust iteration count and quit if too
  473.       * many iterations with no solution
  474.  
  475.       nIters = nIters + 1
  476.       if nIters > nMaxiter
  477.          n_Flag = 5
  478.          fNearx = float( 0 )
  479.          exit
  480.       endif
  481.  
  482.       * And finally keep as the new fFarx that one
  483.       * of the previous approximations, fFarx and
  484.       * fOldx, at which the function has a sign opposite
  485.       * to that at the new approximation, fNearx.
  486.  
  487.       if sign( fNeary ) = sign( fFary )
  488.          fFarx = fOldx
  489.          fFary = fOldy
  490.       endif
  491.    enddo
  492.  
  493. RETURN fNearx
  494. *-- EoF: Zeroin()
  495.  
  496. FUNCTION Median
  497. *-------------------------------------------------------------------------------
  498. *-- Programmer..: Oktay Amiry (Borland Technical Support)
  499. *-- Date........: 12/01/1992
  500. *-- Notes.......: Median refers to the middle value in a list; it is the 
  501. *--               halfway point from the lowest value to the highest.
  502. *--               This was published in TechNotes, December 1992 issue.
  503. *-- Written for.: dBASE IV, 1.5
  504. *-- Rev. History: 12/01/1992 -- Original Release
  505. *-- Calls.......: None
  506. *-- Called by...: Any
  507. *-- Usage.......: Median(<nField>)
  508. *-- Example.....: ?Median("SCORE")
  509. *-- Returns.....: Character value
  510. *-- Parameters..: nField = an indexed numeric field name in the current database
  511. *-------------------------------------------------------------------------------
  512.     parameters nField
  513.     private nCount, lEven,cLow,cHigh,cMed
  514.     
  515.     do case
  516.         case isblank(dbf())
  517.             RETURN "No database is in use"
  518.         case tagcount() = 0
  519.             RETURN "Specified file must be indexed"
  520.         case type(nField) # "N"
  521.             RETURN "Specified field must be numeric"
  522.         case upper(key()) # upper(nField)
  523.             nCount = 1
  524.             do while nCount <= tagcount()
  525.                 if upper(key(nCount)) # upper(nField)
  526.                     nCount - nCount + 1
  527.                 else
  528.                     set order to tag(nCount)
  529.                     exit
  530.                 endif
  531.             enddo
  532.             if upper(key(nCount)) # upper(nField)
  533.                 RETURN "Specified field must be indexed"
  534.             endif
  535.     endcase
  536.     go top
  537.     lEven = mod(reccount(),2) = 0
  538.     if lEven
  539.         skip ((reccount()/2) -1)
  540.         cLow = ltrim(str(&nField.))
  541.         skip
  542.         cHigh = ltrim(str(&nField.))
  543.     else
  544.         skip int(reccount()/2)
  545.         cMed = ltrim(str(&nField.))
  546.     endif
  547.  
  548. RETURN iif(lEven,cLow+" TO "+cHigh,cMed)
  549. *-- EoF: Median()
  550.  
  551. FUNCTION Mode
  552. *-------------------------------------------------------------------------------
  553. *-- Programmer..: Oktay Amiry (Borland Technical Support)
  554. *-- Date........: 12/01/1992
  555. *-- Notes.......: Used to determine the item which occurs most frequently
  556. *--               in a list. Printed in TechNotes, December 1992.
  557. *-- Written for.: dBASE IV, 1.5
  558. *-- Rev. History: 12/01/1992 -- Original Release
  559. *-- Calls.......: None
  560. *-- Called by...: Any
  561. *-- Usage.......: Mode(<xField>)
  562. *-- Example.....: ?Mode("SEX")
  563. *-- Returns.....: The item that is the most common among those in that field.
  564. *-- Parameters..: xField = an indexed field (it must be indexed)
  565. *-------------------------------------------------------------------------------
  566.  
  567.     parameters xField
  568.     private nCount,nMem,nOccur,nHigh,nName
  569.     
  570.     do case
  571.         case tagcount() = 0
  572.             RETURN "Specified file must be indexed"
  573.         case reccount() <= 1
  574.             RETURN "Invalid number of records for MODE()"
  575.         *case type(xField) # "N"
  576.             *RETURN "Specified field must be Numeric"
  577.     endcase
  578.     if upper(order()) # upper(xField)
  579.         RETURN "Specified field must be indexed"
  580.     endif
  581.     
  582.     go top
  583.     nHigh = 1
  584.     nCount = 0
  585.     scan
  586.         xCurrent = &xField.
  587.         xSame = &xField.
  588.         scan while xCurrent = xSame
  589.             xCurrent = &xField.
  590.             if xCurrent = xSame
  591.                 nCount = nCount + 1
  592.             endif
  593.         endscan
  594.         if nCount > nHigh
  595.             nHigh = nCount
  596.             xReturn = xSame
  597.         else
  598.             if nCount = nHigh
  599.                 xReturn = -1
  600.             endif
  601.         endif
  602.         nCount = 0
  603.     endscan
  604.  
  605. RETURN iif(nHigh = 1, -1, xReturn)
  606. *-- EoF: Mode()
  607.  
  608. FUNCTION Prcntl
  609. *-------------------------------------------------------------------------------
  610. *-- Programmer..: Oktay Amira (Borland Technical Support)
  611. *-- Date........: 12/01/1992
  612. *-- Notes.......: Returns the percentile ranking of a number compared to
  613. *--               a list. Printed in TechNotes, December 1992.
  614. *-- Written for.: dBASE IV, 1.5
  615. *-- Rev. History: 12/01/1992
  616. *-- Calls.......: None
  617. *-- Called by...: Any
  618. *-- Usage.......: Prcntl(<nField>,<nrank>)
  619. *-- Example.....: ?Prcntl("SCORE",90)
  620. *-- Returns.....: numeric
  621. *-- Parameters..: nField = a numeric field in a database
  622. *--               nRank  = number to be ranked.
  623. *-------------------------------------------------------------------------------
  624.  
  625.     parameters nField,nRank
  626.     private nField,nRank,nPercentile
  627.     
  628.     count to nPercentile for nRank > &nField.
  629.     
  630. RETURN (nPercentile * 100) / reccount()
  631. *-- EoF: Prcntl()
  632.  
  633. FUNCTION Range
  634. *-------------------------------------------------------------------------------
  635. *-- Programmer..: Oktay Amira (Borland Technical Support)
  636. *-- Date........: 12/01/1992
  637. *-- Notes.......: Returns a number representing the difference between the
  638. *--               highest and lowest numbers of a list.
  639. *--               Originally printed in TechNotes, Dec. 1992
  640. *-- Written for.: dBASE IV, 1.5
  641. *-- Rev. History: 12/01/1992 -- Original Release
  642. *-- Calls.......: None
  643. *-- Called by...: Any
  644. *-- Usage.......: Range(<nField>)
  645. *-- Example.....: ?Range("SCORE")
  646. *-- Returns.....: Numeric
  647. *-- Parameters..: nField = a numeric field in an open database
  648. *-------------------------------------------------------------------------------
  649.  
  650.     parameters nField
  651.     private nHigh,nLow
  652.     
  653.     calculate max(&nField.) to nHigh, min(&nField.) to nLow
  654.  
  655. RETURN (nHigh - nLow)
  656. *-- EoF: Range()
  657.  
  658. FUNCTION RMS
  659. *-------------------------------------------------------------------------------
  660. *-- Programmer..: Oktay Amira (Borland Technical Support)
  661. *-- Date........: 12/01/1992
  662. *-- Notes.......: Root-Mean-Square can be applied to any numeric list
  663. *--               (ordinal, interval, and ratio) to find the overall size
  664. *--               of the numbers in the list, in lieu of their signs.
  665. *--               Printed in TechNotes, December 1992.
  666. *-- Written for.: dBASE IV, 1.5
  667. *-- Rev. History: 12/01/1992 -- Original Release
  668. *-- Calls.......: None
  669. *-- Called by...: Any
  670. *-- Usage.......: RMS(<nField>)
  671. *-- Example.....: ?RMS("SCORE")
  672. *-- Returns.....: numeric
  673. *-- Parameters..: nField = a numeric field
  674. *-------------------------------------------------------------------------------
  675.  
  676.     parameters nField
  677.     private nTotal
  678.     
  679.     calculate sum(&nField. ^ 2) to nTotal
  680.  
  681. RETURN sqrt((nTotal/reccount()))
  682. *-- EoF: RMS()
  683.  
  684. FUNCTION SD
  685. *-------------------------------------------------------------------------------
  686. *-- Programmer..: Oktay Amira (Borland Technical Support)
  687. *-- Date........: 12/01/1992
  688. *-- Notes.......: Standard Deviation -- similar to the dBASE STD function.
  689. *--               The standard deviation shows how far away numbers on a list
  690. *--               are from their average. The value yielded by standard
  691. *--               deviation is in the same units as the numbers which are used
  692. *--               to calculate the SD. The SD() function can take two forms:
  693. *--               an unbiased (n-1) method and the biased (n-method) form. The
  694. *--               SD() function, by default, takes the biased form, which is
  695. *--               the standard deviation for a population based on the 
  696. *--               entire population. With the explicit second parameter being
  697. *--               "S", the SD() performs the unbiased method, which is the
  698. *--               standard deviation for a population that is based on a sample.
  699. *--               This latter method, which is also referred to as the SD+,
  700. *--               is usually the value produced by statistical calculators and
  701. *--               is frequently higher than population-based SD.
  702. *--               Printed in TechNotes, December 1992.
  703. *-- Written for.: dBASE IV, 1.5
  704. *-- Rev. History: 12/01/1992 -- Original Release
  705. *-- Calls.......: None
  706. *-- Called by...: Any
  707. *-- Usage.......: SD(<nField>[,"S"])
  708. *-- Example.....: ?SD("SCORE","S")
  709. *-- Returns.....: numeric
  710. *-- Parameters..: nField = a numeric field
  711. *-------------------------------------------------------------------------------
  712.  
  713.     parameters nField, cType
  714.     private nAverage, nEntry
  715.     
  716.     calculate avg(&nField. ^ 2) to nEntry, avg(&nField.) to nAverage
  717.     nAverage = nAverage ^ 2
  718.  
  719. RETURN iif(type("CTYPE") = "C" .and. upper(cType) = "S",;
  720.            sqrt(nEntry-nAverage)/sqrt((reccount()-1)/reccount()),;
  721.            sqrt(nEntry-nAverage)
  722. *-- EoF: SD()
  723.  
  724. FUNCTION SU
  725. *-------------------------------------------------------------------------------
  726. *-- Programmer..: Oktay Amira (Borland Technical Support)
  727. *-- Date........: 12/01/1992
  728. *-- Notes.......: Standard Units is a unit of measurement often referred to
  729. *--               in various statistical calculations. Suffice it to note that
  730. *--               SU is an intrinsic way of looking at data, indicating
  731. *--               whether a value is above or below the average.
  732. *--               A positive SU indicates the value was above average,
  733. *--               while a negative SU indicates a below average value.
  734. *--               Printed in TechNotes, December 1992.
  735. *-- Written for.: dBASE IV, 1.5
  736. *-- Rev. History: 12/01/1992 -- Original Release
  737. *-- Calls.......: None
  738. *-- Called by...: Any
  739. *-- Usage.......: SU(<nField>,<nConvert>)
  740. *-- Example.....: ?RMS("SCORE",75)
  741. *-- Returns.....: numeric
  742. *-- Parameters..: nField   = a numeric field
  743. *--               nConvert = number to be converted
  744. *-------------------------------------------------------------------------------
  745.  
  746.     parameters nField,nNum
  747.     private nAverage,nStandard
  748.     
  749.     calculate avg(&nField.) to nAverage, std(&nField.) to nStandard
  750.  
  751. RETURN iif(nStandard # 0,(nNum-nAverage)/nStandard,0)
  752. *-- EoF: SU()
  753.  
  754. FUNCTION CoEf
  755. *-------------------------------------------------------------------------------
  756. *-- Programmer..: Oktay Amira (Borland Technical Support)
  757. *-- Date........: 12/01/1992
  758. *-- Notes.......: Correlation CoEfficiant -- uses as parameters the field
  759. *--               names of two numeric fields representing two data sets.
  760. *--               Both of these fields must belong to one database.
  761. *--               The value returned is always between +1 and -1.
  762. *--               Printed in TechNotes, December 1992.
  763. *-- Written for.: dBASE IV, 1.5
  764. *-- Rev. History: 12/01/1992 -- Original Release
  765. *-- Calls.......: None
  766. *-- Called by...: Any
  767. *-- Usage.......: CoEf(<nField1>,<nField2>)
  768. *-- Example.....: ?CoEf("SCORE","MIDTERM")
  769. *-- Returns.....: numeric
  770. *-- Parameters..: nField1  = a numeric field
  771. *--               nField2  = second numeric field
  772. *-------------------------------------------------------------------------------
  773.  
  774.     parameters nField1, nField2
  775.     private nTotal, n1Avg, n1Std, n2Avg, n2Std
  776.     
  777.     ntotal = 0
  778.     calculate avg(&nField1.) to n1Avg,;
  779.                  std(&nField1.) to n1Std,;
  780.                  avg(&nField2.) to n2Avg,;
  781.                  std(&nField2.) to n2Std
  782.     scan
  783.         nTotal - nTotal + (&nField1. * &nField2.)
  784.     endscan
  785. RETURN ( (nTotal/reccount()) - (n1Avg * n2Avg) ) / (n1Std * n2Std)
  786. *-- EoF: CoEf()
  787.  
  788. FUNCTION Choose
  789. *-------------------------------------------------------------------------------
  790. *-- Programmer..: Oktay Amira (Borland Technical Support)
  791. *-- Date........: 12/01/1992
  792. *-- Notes.......: Returns the nth item in a list. The UDF assumes that items
  793. *--               in the list are separated by commas.
  794. *--               Printed in TechNotes, December 1992.
  795. *-- Written for.: dBASE IV, 1.5
  796. *-- Rev. History: 12/01/1992 -- Original Release
  797. *-- Calls.......: None
  798. *-- Called by...: Any
  799. *-- Usage.......: Choose(<cList>,<nItem>[,<cDelimiter>])
  800. *-- Example.....: ?Choose("A,B,C",2)        or
  801. *--               ?Choose(TIME(),1,":")
  802. *-- Returns.....: Character
  803. *-- Parameters..: cList      = List of items, normally separated by commas
  804. *--                             (see optional parameter to change delimiter)
  805. *--               nItem      = item position in list
  806. *--               cDelimiter = optional -- if other than a comma is used to
  807. *--                            separate items in the list, define it here.
  808. *-------------------------------------------------------------------------------
  809.  
  810.     parameter cList, nItem, cDelimiter
  811.     
  812.     do case
  813.         case pcount() < 2
  814.             RETURN "Invalid number of parameters"
  815.         case type("cList") # "C"
  816.             RETURN "First parameter must be character"
  817.         case type("nITEM") # "N"
  818.             RETURN "Second parameter must be numeric"
  819.         case type("cDelimiter") = "L" .and. cDelimiter
  820.             RETURN "Third parameter must be character or empty"
  821.         case type("cDelimiter") = "L" .and. .not. cDelimiter
  822.             cDelimiter = ","
  823.             if .not. cDelimiter $ cList
  824.                 RETURN "Wrong or missing delimiters in parameter"
  825.             endif
  826.         case type("Cdelimiter") = "C" .and. .not. cDelimiter $ cList
  827.             RETURN "First parameter is missing specified delimiter"
  828.     endcase
  829.     
  830.     nCom = 1
  831.     nBegin = 1
  832.     nEnd = 1
  833.     do while nEnd <= len(trim(cList))
  834.         if substr(cList,nEnd,1) # cDelimiter
  835.             nEnd = nEnd + 1
  836.         else
  837.             if nCom # nItem
  838.                 nCom = nCom + 1
  839.                 nEnd = nEnd + 1
  840.                 nBegin = nEnd
  841.             else
  842.                 nEnd = nEnd - nBegin
  843.                 exit
  844.             endif
  845.         endif
  846.     enddo
  847.  
  848. RETURN substr(cList,nBegin,nEnd)
  849. *-- EoF: Choose()
  850.  
  851. *-------------------------------------------------------------------------------
  852. *-- The functions below are here by courtesy ... (to make life easier on the
  853. *-- poor programmer ...)
  854. *-------------------------------------------------------------------------------
  855.  
  856. FUNCTION Npv
  857. *-------------------------------------------------------------------------------
  858. *-- Programmer..: Tony Lima (CIS: 72331,3724) and Jay Parsons (CIS: 70160,340)
  859. *-- Date........: 03/01/1992
  860. *-- Notes.......: Net present value of array aCashflow[ nPeriods ]
  861. *--               Calculates npv given assumed rate and # periods.
  862. *-- Written for.: dBASE IV, 1.1
  863. *-- Rev. History: 03/01/1992 -- Original Release
  864. *-- Calls.......: None
  865. *-- Called by...: Any
  866. *-- Usage.......: NPV(<nRate>,<nPeriods>)
  867. *-- Example.....: ? NPV( .06, 6 )
  868. *-- Returns.....: Float = value of the project at given rate
  869. *-- Parameters..: nRate    = Interest Rate
  870. *--             : nPeriods = Number of Periods to calculate for
  871. *-- Other inputs: Requires the array aCashflow[ ] set up before calling.
  872. *--             : Each of its elements [n] holds the cash flow at the
  873. *--             : beginning of period n, with a negative amount indicating
  874. *--             : a cash outflow.  Elements of value 0 must be included for
  875. *--             : all periods with no cash flow, and all periods must be of
  876. *--             : equal length.
  877. *--             : If the project is expected to require an immediate outlay
  878. *--             : of $6,000 and to return $2,000 at the end of each of the
  879. *--             : first five years thereafter, the array will be:
  880. *--             :       aCashflow[1] = -6000
  881. *--             :       aCashflow[2] =  2000
  882. *--             :       aCashflow[3] =  2000
  883. *--             :           * * *
  884. *--             :       aCashflow[6] =  2000
  885. *--             : Rewriting function to have array name passed as a parameter
  886. *--             : is possible, but will slow down execution to an extent that
  887. *--             : will be very noticeable if this function is being repeatedly
  888. *--             : executed, as by Zeroin() to find an Internal Rate of Return.
  889. *-------------------------------------------------------------------------------
  890.  
  891.     parameters nRate, nPeriods
  892.     private nDiscount, nFactor, nPeriod, nNpv
  893.     nPeriod = 1
  894.     nNpv = aCashflow[ 1 ]
  895.     nDiscount = float( 1 )
  896.     nFactor = 1 / ( 1 + nRate )
  897.     do while nPeriod < nPeriods
  898.         nPeriod = nPeriod + 1
  899.         nDiscount = nDiscount * nFactor
  900.         nNpv = nNpv + aCashflow[ nPeriod ] * nDiscount
  901.     enddo
  902.     
  903. RETURN nNpv
  904. *-- EoF: Npv()
  905.  
  906. FUNCTION ArrayRows
  907. *-------------------------------------------------------------------------------
  908. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  909. *-- Date........: 03/01/1992
  910. *-- Notes.......: Number of Rows in an array
  911. *-- Written for.: dBASE IV, 1.1
  912. *-- Rev. History: 03/01/1992 -- Original Release
  913. *-- Calls.......: None
  914. *-- Called by...: Any
  915. *-- Usage.......: ArrayRows("<aArray>")
  916. *-- Example.....: n = ArrayRows("aTest")
  917. *-- Returns.....: numeric
  918. *-- Parameters..: aArray      = Name of array 
  919. *-------------------------------------------------------------------------------
  920.  
  921.     parameters aArray
  922.     private nHi, nLo, nTrial, nDims
  923.     nLo = 1
  924.     nHi = 1170
  925.     if type( "&aArray[ 1, 1 ]" ) = "U"
  926.       nDims = 1
  927.     else
  928.      nDims = 2
  929.     endif
  930.     do while .T.
  931.      nTrial = int( ( nHi + nLo ) / 2 )
  932.       if nHi < nLo
  933.         exit
  934.       endif
  935.      if nDims = 1 .and. type( "&aArray[ nTrial ]" ) = "U" .or. ;
  936.        nDims = 2 .and. type( "&aArray[ nTrial, 1 ]" ) = "U"
  937.         nHi = nTrial - 1
  938.       else
  939.         nLo = nTrial + 1
  940.       endif
  941.     enddo
  942.     
  943. RETURN nTrial
  944. *-- EoF: ArrayRows()
  945.  
  946. *-------------------------------------------------------------------------------
  947. *-- End of Program: STATS.PRG
  948. *-------------------------------------------------------------------------------
  949.