I am trying to add up all the Shannon entropy of all the alphabetical characters in a word document.
Instead of it adding the characters it gives me what I put for character(27) as an answer.
Dim characters(1 To 27) As Double
Dim x As Integer 'for looping
Dim tot As Double 'The final value
characters(1) = 0.1859 'Space
characters(2) = 0.0856 'A
characters(3) = 0.0139 'B
characters(4) = 0.0279 'C
characters(5) = 0.0378 'D
characters(6) = 0.1304 'E
characters(7) = 0.0289 'F
characters(8) = 0.0199 'G
characters(9) = 0.0528 'H
characters(10) = 0.0627 'I
characters(11) = 0.0013 'J
characters(12) = 0.0042 'K
characters(13) = 0.0339 'L
characters(14) = 0.0249 'M
characters(15) = 0.0707 'N
characters(16) = 0.0797 'O
characters(17) = 0.0199 'P
characters(18) = 0.0012 'Q
characters(19) = 0.0677 'R
characters(20) = 0.0607 'S
characters(21) = 0.1045 'T
characters(22) = 0.0249 'U
characters(23) = 0.0092 'V
characters(24) = 0.0149 'W
characters(25) = 0.0017 'X
characters(26) = 0.0199 'Y
characters(27) = 0.0008 'Z
For x = 1 To 27
tot = tol + characters(x)
Next
MsgBox "The Shannon entropy of the alphabetic characters in this document is " & tot
What I am getting
Today was a good day
The Shannon entropy of the characters in this document is 0.0008
What I am trying to get
Today was a good day
The Shannon entropy of the characters in this document is 1.2798542258337
I don't know if you have noticed that you wrote this:
For x = 1 To 27
tot = tol + characters(x)
Next
...while you might have wanted to write this:
For x = 1 To 27
tot = tot + characters(x)
Next
In fact, what you want is that tot is iteratively summing to itself a new value. But if you write
tot = tol + characters(x)
...what happens is that tol is always = 0 (because it doesn't preserve it's value and gets its 0 value by default) and so tot will be obviously equal to 0 + the last element because it does not keep its changes either. It's a typo, just change tot = tol + characters(x) with tot = tot + characters(x) and the code will work.
Related
I have an example of a program that shows how to set up a counter for how many times each letter of the alphabet was used. I don't understand the syntax of the middle portion of the program.
LET letter$ = MID$(sentence$, LETTERNUMBER, 1)
I have tried searching on youtube and tutorials online
CLS
REM Make Counters for each Letter!!!
DIM Count(ASC("A") TO ASC("Z"))
REM Get the Sentence
INPUT "Enter Sentence:", sentence$
LET sentence$ = UCASE$(sentence$)
FOR I = ASC("A") TO ASC("Z")
LET Count(I) = 0
NEXT I
FOR LETTERNUMBER = 1 TO LEN(sentence$)
LET letter$ = MID$(sentence$, LETTERNUMBER, 1)
IF (letter$ >= "A") AND (letter$ <= "Z") THEN
LET k = ASC(letter$)
LET Count(k) = Count(k) + 1
END IF
NEXT LETTERNUMBER
PRINT
REM Display These Counts Now
LET letterShown = 0
FOR letternum = ASC("A") TO ASC("Z")
LET letter$ = CHR$(letternum)
IF Count(letternum) > 0 THEN
PRINT USING "\\## "; letter$; Count(letternum);
END IF
LET letterShown = letterShown + 1
IF letterShown = 7 THEN
PRINT
LET letterShown = 0
END IF
NEXT letternum
END
A through Z appears with the count of how many times they appeared.
The MID$ function returns a portion of a STRING's value from any position inside a string.
Syntax:
MID$(stringvalue$, startposition%[, bytes%])
Parameters:
stringvalue$
can be any literal or variable STRING value having a length. See LEN.
startposition%
designates the non-zero position of the first character to be returned by the function.
bytes%
(optional) tells the function how many characters to return including the first character when it is used.
Another method to calculate characters in a string:
REM counts and displays characters in a string
DIM count(255) AS INTEGER
PRINT "Enter string";: INPUT s$
' parse string
FOR s = 1 TO LEN(s$)
x = ASC(MID$(s$, s, 1))
count(x) = count(x) + 1
NEXT
' display string values
FOR s = 1 TO 255
PRINT s; "="; count(s); " ";
IF (s MOD 8) = 0 THEN
PRINT
IF (s MOD 20) = 0 THEN
PRINT "Press key:";
WHILE INKEY$ = "": WEND: PRINT
END IF
END IF
NEXT
END
I have a set which has an unknown number of objects. I want to associate a label to each one of these objects. Instead of labeling each object with a number I want to label them with letters.
For example the first object would be labeled A the second B and so on.
When I get to Z, the next object would be labeled AA
AZ? then BA, BB, BC.
ZZ? then AAA, AAB, AAC and so on.
I'm working using Mapbasic (similar to VBA), but I can't seem to wrap my head around a dynamic solution. My solution assumes that there will be a max number of objects that the set may or may not exceed.
label = pos1 & pos2
Once pos2 reaches ASCII "Z" then pos1 will be "A" and pos2 will be "A". However, if there is another object after "ZZ" this will fail.
How do I overcome this static solution?
Basically what I needed was a Base 26 Counter. The function takes a parameter like "A" or "AAA" and determines the next letter in the sequence.
Function IncrementAlpha(ByVal alpha As String) As String
Dim N As Integer
Dim num As Integer
Dim str As String
Do While Len(alpha)
num = num * 26 + (Asc(alpha) - Asc("A") + 1)
alpha = Mid$(alpha, 2,1)
Loop
N = num + 1
Do While N > 0
str = Chr$(Asc("A") + (N - 1) Mod 26) & str
N = (N - 1) \ 26
Loop
IncrementAlpha = str
End Function
If we need to convert numbers to a "letter format" where:
1 = A
26 = Z
27 = AA
702 = ZZ
703 = AAA etc
...and it needs to be in Excel VBA, then we're in luck. Excel's columns are "numbered" the same way!
Function numToLetters(num As Integer) As String
numToLetters = Split(Cells(1, num).Address(, 0), "$")(0)
End Function
Pass this function a number between 1 and 16384 and it will return a string between A and XFD.
Edit:
I guess I misread; you're not using Excel. If you're using VBA you should still be able to do this will the help of an reference to an Excel Object Library.
This should get you going in terms of the logic. Haven't tested it completely, but you should be able to work from here.
Public Function GenerateLabel(ByVal Number As Long) As String
Const TOKENS As String = "ZABCDEFGHIJKLMNOPQRSTUVWXY"
Dim i As Long
Dim j As Long
Dim Prev As String
j = 1
Prev = ""
Do While Number > 0
i = (Number Mod 26) + 1
GenerateLabel = Prev & Mid(TOKENS, i, 1)
Number = Number - 26
If j > 0 Then Prev = Mid(TOKENS, j + 1, 1)
j = j + Abs(Number Mod 26 = 0)
Loop
End Function
I have a spreadsheet/userform combo that takes user input to calculate product pricing/percent tax/and square footage in consideration to output a total cost for flooring in one of the userform's textboxes.
My userform is calculating everything correctly, but I am trying to figure out how to format the output box so that it only displays values up to two digits past the decimal (i.e. $1.00). Currently, it displays up to four digits or more beyond the decimal (as seen in the Total Area, Tax Amount, and Final Price text boxes).
My userform code is as follows (I left out some non-pertinent sections that had to do with opening and closing the userform but everything that has to do with the functioning of it is there):
Public Sub SumTool()
Dim A, B, C, D, E, F As Double
Dim x As Double
Dim finalSum As Double
Dim addUp As Double
Dim BeforePercent As Double
Dim Prcnt As Double
Dim percentALT As Double
Dim percentSum As Double
Dim i As Integer
addUp = 0
finalSum = 0
BeforePercent = 0
x = 0
i = 0
'These are all area measurements
A = 280
B = 118
C = 96
D = 243
E = 38
F = 83
Do While i < 1
'These are checks to see if checkboxes in the userform are True/False and
'correspond to the area measurements above
If LR.Value = True Then
x = x + A
Else
x = x
End If
If BR1.Value = True Then
x = x + B
Else
x = x
End If
If BR2.Value = True Then
x = x + C
Else
x = x
End If
If KT.Value = True Then
x = x + D
Else
x = x
End If
If BA.Value = True Then
x = x + E
Else
x = x
End If
If HALL.Value = True Then
x = x + F
Else
x = x
End If
i = i + 1
Loop
'I have different calculations because the user has the option of
'whether they want to include tax or not. If they do not (first option)
'no special conversions have to take place. If they do, the program has to
'take the entry and convert it from 5 or 10 to 0.05 or 0.10 and then carry
'forward with the rest of the operations
If Me.Y.Value = False Then
Prcnt = 0
addUp = x
finalSum = addUp * Me.ProductPrice.Value
Me.FinalResultsBox.Value = finalSum
Me.SqFtBox.Value = addUp
Me.TaxAmountValue.Value = 0
Else
Prcnt = Me.SalesTaxNumber.Value
addUp = x
percentALT = Prcnt * 0.01
BeforePercent = addUp * Me.ProductPrice.Value
percentSum = percentALT * BeforePercent
finalSum = BeforePercent + percentSum
Me.FinalResultsBox.Value = finalSum
Me.SqFtBox.Value = addUp
Me.TaxAmountValue.Value = percentSum
End If
End Sub
You may try something like this...
Me.FinalResultsBox.Value = Format(finalSum, "$0.00")
I am banging my head against the wall for a while now trying different techniques.
None of them are working well.
I have two strings.
I need to compare them and get an exact percentage of match,
ie. "four score and seven years ago" TO "for scor and sevn yeres ago"
Well, I first started by comparing every word to every word, tracking every hit, and percentage = count \ numOfWords. Nope, didn't take into account misspelled words.
("four" <> "for" even though it is close)
Then I started by trying to compare every char in each char, incrementing the string char if not a match (to count for misspellings). But, I would get false hits because the first string could have every char in the second but not in the exact order of the second. ("stuff avail" <> "stu vail" (but it would come back as such, low percentage, but a hit. 9 \ 11 = 81%))
SO, I then tried comparing PAIRS of chars in each string. If string1[i] = string2[k] AND string1[i+1] = string2[k+1], increment the count, and increment the "k" when it doesn't match (to track mispellings. "for" and "four" should come back with a 75% hit.) That doesn't seem to work either. It is getting closer, but even with an exact match it is only returns 94%. And then it really gets screwed up when something is really misspelled. (Code at the bottom)
Any ideas or directions to go?
Code
count = 0
j = 0
k = 0
While j < strTempName.Length - 2 And k < strTempFile.Length - 2
' To ignore non letters or digits '
If Not strTempName(j).IsLetter(strTempName(j)) Then
j += 1
End If
' To ignore non letters or digits '
If Not strTempFile(k).IsLetter(strTempFile(k)) Then
k += 1
End If
' compare pair of chars '
While (strTempName(j) <> strTempFile(k) And _
strTempName(j + 1) <> strTempFile(k + 1) And _
k < strTempFile.Length - 2)
k += 1
End While
count += 1
j += 1
k += 1
End While
perc = count / (strTempName.Length - 1)
Edit: I have been doing some research and I think I initially found the code from here and translated it to vbnet years ago. It uses the Levenshtein string matching algorithm.
Here is the code I use for that, hope it helps:
Sub Main()
Dim string1 As String = "four score and seven years ago"
Dim string2 As String = "for scor and sevn yeres ago"
Dim similarity As Single =
GetSimilarity(string1, string2)
' RESULT : 0.8
End Sub
Public Function GetSimilarity(string1 As String, string2 As String) As Single
Dim dis As Single = ComputeDistance(string1, string2)
Dim maxLen As Single = string1.Length
If maxLen < string2.Length Then
maxLen = string2.Length
End If
If maxLen = 0.0F Then
Return 1.0F
Else
Return 1.0F - dis / maxLen
End If
End Function
Private Function ComputeDistance(s As String, t As String) As Integer
Dim n As Integer = s.Length
Dim m As Integer = t.Length
Dim distance As Integer(,) = New Integer(n, m) {}
' matrix
Dim cost As Integer = 0
If n = 0 Then
Return m
End If
If m = 0 Then
Return n
End If
'init1
Dim i As Integer = 0
While i <= n
distance(i, 0) = System.Math.Max(System.Threading.Interlocked.Increment(i), i - 1)
End While
Dim j As Integer = 0
While j <= m
distance(0, j) = System.Math.Max(System.Threading.Interlocked.Increment(j), j - 1)
End While
'find min distance
For i = 1 To n
For j = 1 To m
cost = (If(t.Substring(j - 1, 1) = s.Substring(i - 1, 1), 0, 1))
distance(i, j) = Math.Min(distance(i - 1, j) + 1, Math.Min(distance(i, j - 1) + 1, distance(i - 1, j - 1) + cost))
Next
Next
Return distance(n, m)
End Function
Did not work for me unless one (or both) of following are done:
1) use option compare statement "Option Compare Text" before any Import declarations and before Class definition (i.e. the very, very first line)
2) convert both strings to lowercase using .tolower
Xavier's code must be correct to:
While i <= n
distance(i, 0) = System.Math.Min(System.Threading.Interlocked.Increment(i), i - 1)
End While
Dim j As Integer = 0
While j <= m
distance(0, j) = System.Math.Min(System.Threading.Interlocked.Increment(j), j - 1)
End While
I was running tests on my software today and found that some of the values it was producing weren't correct.
I decided to step through the code and noticed that the variables I had assigned to textbox values on my userform when hovered over said empty, even though when hovering over the textbox assigned to it, the value inputted by the user showed.
For Example,
n = BiTimeSteps_TextBox.Value
when hovered over
n = empty
even though
BiTimeSteps_TextBox.Value = 2
when hovered over.
So say I have a formula shortly after that says
d = n*2 ,
n when hovered over says empty and d is made 0 when it shouldn't be.
Someone told me if I switch it around to
BiTimeSteps_TextBox.Value = n
it should be recognised but it is still not.
What could possibly be causing this?
See full code below: (it aims to price options using the binomial tree pricing method)
S = BiCurrentStockPrice_TextBox.Value
X = BiStrikePrice_TextBox.Value
r = BiRisk_Free_Rate_TextBox.Value
T = BiexpTime_TextBox.Value
Sigma = BiVolatility_TextBox.Value
n = BiTimeSteps_TextBox.Value
Dim i, j, k As Integer
Dim p, V, u, d, dt As Double
dt = T / n ' This finds the value of dt
u = Exp(Sigma * Sqr(dt)) 'formula for the up factor
d = 1 - u 'formula for the down factor
'V value of option
'array having the values
Dim bin() As Double 'is a binomial arrays, it stores the value of each node, there is a loop
'work out the risk free probability
p = (1 + r - d) / (u - d)
'probability of going up
ReDim bin(n + 1) As Double
'it redims the array, and n+1 is used because it starts from zero
'------------------------------------------------------------------------------------------------------------------------------
''European Call
If BiCall_CheckBox = True Then
For i = 0 To n 'payoffs = value of option at final time
bin(i + 1) = Application.WorksheetFunction.Max(0, (u ^ (n - i)) * (d ^ i) * S - X)
'It takes the max payoff or 0
Cells(i + 20, n + 2) = bin(i + 1) 'to view payoffs on the isolated column on the right
Next i
End If
'european put
If BiPut_CheckBox = True Then
For i = 0 To n 'payoffs = value of option at final time
bin(i + 1) = Application.WorksheetFunction.Max(0, X - (S * (u * (n - i)) * (d * i)))
' European Put- It takes the max payoff or 0
Cells(i + 20, n + 2) = bin(i + 1) 'to view payoffs on the isolated column on the right
Next i
End If
For k = 1 To n 'backward column loop
For j = 1 To (n - k + 1) 'loop down the column loop
bin(j) = (p * bin(j) + (1 - p) * bin(j + 1)) / (1 + r)
Cells(j + 19, n - k + 2) = bin(j)
'' print the values along the column, view of tree
Next j
Next k
Worksheets("Binomial").Cells(17, 2) = bin(1) ' print of the value V
BiOptionPrice_TextBox = bin(1)