I want to create a VBA class where the class is instantiated with the New keyword but replicates a primitive VBA data type
Example:
Sub test()
Dim replicate_double As New ClassDouble ' <- from some documentation I am referencing and attempting to replicate, it says that this class is a wrapper to a ClassVariant class module
replicate_double = 2.234 ' <- should replicate as if doing a Double data type assignment
Debug.Print replicate_double ' <- should print "2.234"
End Sub
I'm not entirely sure how to replicate this functionality but I've tried multiple things such as testing with a Property Set replicate_double() End Property. Passing parameters to the Class_initialize()
You need to define a class with a default method for the value. I prefer to use a factory class so that I can avoid the new statement at the point of construction.
Here is an example I've used for a class called 'oNumber'
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
End
Attribute VB_Name = "oNumber"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_Description = "Class for managing number primitives"
Option Explicit
'#PredeclaredId
'#Exposed
'#ModuleDescription("Class for managing number primitives")
Private Type Properties
Number As Variant
End Type
Private p As Properties
Public Function Deb(ByVal ipNumber As Variant) As oNumber
With New oNumber
Set Deb = .ReadyToUseInstance(ipNumber)
End With
End Function
' You could if you wanted add checks to the method below for ipNumber actually being a number
Friend Function ReadyToUseInstance(ByVal ipNumber As Variant) As oNumber
p.Number = ipNumber
Set ReadyToUseInstance = Me
End Function
'#DefaultMember
Public Property Get Value() As Variant
Attribute Value.VB_VarUserMemId = 0
Value = p.Number
End Property
Public Property Set Value(ByVal ipNumber As Variant)
p.Number = ipNumber
End Property
Public Function Clone() As oNumber
Set Clone = oNumber.Deb(p.Number)
End Function
Public Function AsVarType() As VbVarType
AsVarType = VarType(p.Number)
End Function
Public Function TypeName() As String
TypeName = VBA.TypeName(p.Number)
End Function
Public Function ToString() As String
ToString = CStr(p.Number)
End Function
Public Function ToByte() As Byte
ToByte = CByte(p.Number)
End Function
Public Function ToDate() As Date
ToDate = CDate(p.Number)
End Function
Public Function ToDecimal() As Decimal
ToDecimal = CDec(p.Number)
End Function
Public Function ToDouble() As Double
ToDouble = CDbl(p.Number)
End Function
Public Function ToInteger() As Integer
ToInteger = CInt(p.Number)
End Function
Public Function ToLong() As Long
ToLong = CLng(p.Number)
End Function
Public Function ToLongLong() As LongLong
ToLongLong = CLngLng(p.Number)
End Function
Public Function ToLongPtr() As LongPtr
ToLongPtr = CLngPtr(p.Number)
End Function
Public Function ToSingle() As Single
ToSingle = CSng(p.Number)
End Function
In use you create a new oNumber as
Dim myNumber as oNumber
assign mynumber ,oNumber.deb(42)
but because the .Value method has been defined as a default member you can write the remainder of the code pretty much as normal
Dim myResult as oNumber
Set myResult = oNumber.Deb(0) ' oNumbers must alway be specifically initialised
myResult = myresult + 42
'Which is equivalent to
myResult.Value = myResult.Value + 42
Good luck.
PS Please note the comments starting '# are annotations used by the free and fantastic Rubberduck addin for VBA. The annotations manage the Attribute statements that are not made visible in the VBA IDE but which still require setting to allow the above code to work as desired.
Is there any data structure I have access to with efficient sorting and filtering of objects?
For sorting, the System.Collections.ArrayList is perfect, as I simply add a load of classes which Implement IComparable and .Sort(). However I can't find a .Filter() method, as some articles hint may be present (section 9.3).
Is there a good collection type for filtering and sorting custom objects? Preferably something written in a pre-compiled language.
A simple object would look like this:
Implements IComparable 'requires mscorlib.dll, allows sorting
Public itemIndex As Long 'simplest, sorting by an integer value
Private Function IComparable_CompareTo(ByVal obj As Variant) As Long
'for sorting, itemindex is based on current grid sorting mode
If TypeOf obj Is clsGridItem Then
Dim other As clsGridItem: Set other = obj
Dim otherIndex As Long: otherIndex = other.itemIndex
Dim thisIndex As Long: thisIndex = Me.itemIndex
If thisIndex > otherIndex Then
IComparable_CompareTo = 1
ElseIf thisIndex < otherIndex Then
IComparable_CompareTo = -1
Else
IComparable_CompareTo = 0
End If
Else
Err.Raise 5 'obj is wrong type
End If
End Function
And I have an arrayList of them populated with random indices. Of course anything could go in the compare routine (I actually use Select Case for different comparison routines, based on different properties of the classes). A simple filter loop could just check when IComparable_CompareTo = 0
Sort functionality is built-in to the ArrayList Objects, and Filtering is nothing more than "only using the items you need".
For example, this populates an object with random numbers and then filters results to display only those divisible by 42:
Option Explicit
Sub testSort()
Const filter = 42
Dim arr As Object, x As Long, y As Long
Set arr = CreateObject("System.Collections.ArrayList")
' populate array with 100 random numbers
For x = 1 To 420
arr.Add Int(Rnd() * 10000)
Next
' "sort" array
arr.Sort
' dump array to immediate window; "filter" to show only even numbers
For x = 0 To arr.Count - 1
If arr(x) / filter = arr(x) \ filter Then
'item mnatches filter
Debug.Print "arr(" & x & ") = " & arr(x)
y = y + 1
End If
Next x
Debug.Print "Returned " & y & " sorted results (Filter=" & filter & ")"
End Sub
Other Possibilities
You haven't shared much detail on what you need to filter and how, but I was thinking about it further, and you might want to check these out to see if they can be applied to your task:
MSDN: Filter Function (VBA)
Returns a zero-based array containing subset of a string array based on a specified filter criteria
excelfunctions.net: FILTER Function (VBA)
MSDN: Filtering Items in a Collection (VBA)
msdocs: CreateObject("System.Collections.ArrayList") (VB)
Filters the elements of an IEnumerable based on a specified type
msdocs: ArrayList Class Constructors (VB)
Stack Overflow: How to implement class constructor in Visual Basic? (VB)
Stack Overflow: VBA array sort function (VB/VBA)
Wikipedia : Comparison of popular sorting algorithms
Arbitrary filtering of anything enumerable is something Enumerable.Where does, and it does it with the help of delegates, something VBA has no knowledge of, or ability to implement.
WARNING what follows is experimental code that is not intended for production use. It is provided as-is for educational purposes. Use at your own risk.
You can simulate it though. see Wait, is this... LINQ? and Generating and calling code on the fly on Code Review - below is a class I've called Delegate - note that it has its PredeclaredId attribute set to True, so that its Create factory method can be invoked from the default instance. It uses the Regular Expressions library for parsing the definition of the function, and the VBE Extensibility API library to literally generate an "anonymous function" given a string, for example:
Set x = Delegate.Create("(x) => MsgBox(""Hello, "" & x & ""!"")")
x.Execute "Mug"
The above code generates and invokes this function:
Public Function AnonymousFunction(ByVal x As Variant) As Variant
AnonymousFunction = MsgBox("Hello, " & x & "!")
End Function
Which produces what you would expect:
Delegate class
Option Explicit
Private Type TDelegate
Body As String
Parameters As New Collection
End Type
Private Const methodName As String = "AnonymousFunction"
Private this As TDelegate
Friend Property Get Body() As String
Body = this.Body
End Property
Friend Property Let Body(ByVal value As String)
this.Body = value
End Property
Public Function Create(ByVal expression As String) As Delegate
Dim result As New Delegate
Dim regex As New RegExp
regex.Pattern = "\((.*)\)\s\=\>\s(.*)"
Dim regexMatches As MatchCollection
Set regexMatches = regex.Execute(expression)
If regexMatches.Count = 0 Then
Err.Raise 5, "Delegate", "Invalid anonymous function expression."
End If
Dim regexMatch As Match
For Each regexMatch In regexMatches
If regexMatch.SubMatches(0) = vbNullString Then
result.Body = methodName & " = " & Right(expression, Len(expression) - 6)
Else
Dim params() As String
params = Split(regexMatch.SubMatches(0), ",")
Dim i As Integer
For i = LBound(params) To UBound(params)
result.AddParameter Trim(params(i))
Next
result.Body = methodName & " = " & regexMatch.SubMatches(1)
End If
Next
Set Create = result
End Function
Public Function Execute(ParamArray params()) As Variant
On Error GoTo CleanFail
Dim paramCount As Integer
paramCount = UBound(params) + 1
GenerateAnonymousMethod
'cannot break beyond this point
Select Case paramCount
Case 0
Execute = Application.Run(methodName)
Case 1
Execute = Application.Run(methodName, params(0))
Case 2
Execute = Application.Run(methodName, params(0), params(1))
Case 3
Execute = Application.Run(methodName, params(0), params(1), params(2))
Case 4
Execute = Application.Run(methodName, params(0), params(1), params(2), _
params(3))
Case 5
Execute = Application.Run(methodName, params(0), params(1), params(2), _
params(3), params(4))
Case 6
Execute = Application.Run(methodName, params(0), params(1), params(2), _
params(3), params(4), params(5))
Case 7
Execute = Application.Run(methodName, params(0), params(1), params(2), _
params(3), params(4), params(5), _
params(6))
Case 8
Execute = Application.Run(methodName, params(0), params(1), params(2), _
params(3), params(4), params(5), _
params(6), params(7))
Case 9
Execute = Application.Run(methodName, params(0), params(1), params(2), _
params(3), params(4), params(5), _
params(6), params(7), params(8))
Case 10
Execute = Application.Run(methodName, params(0), params(1), params(2), _
params(3), params(4), params(5), _
params(6), params(7), params(8), _
params(9))
Case Else
Err.Raise 5, "Execute", "Too many parameters."
End Select
CleanExit:
DestroyAnonymousMethod
Exit Function
CleanFail:
Resume CleanExit
End Function
Friend Sub AddParameter(ByVal paramName As String)
this.Parameters.Add "ByVal " & paramName & " As Variant"
End Sub
Private Sub GenerateAnonymousMethod()
Dim component As VBComponent
Set component = Application.VBE.VBProjects("Reflection").VBComponents("AnonymousCode")
Dim params As String
If this.Parameters.Count > 0 Then
params = Join(Enumerable.FromCollection(this.Parameters).ToArray, ", ")
End If
Dim signature As String
signature = "Public Function " & methodName & "(" & params & ") As Variant" & vbNewLine
Dim content As String
content = vbNewLine & signature & this.Body & vbNewLine & "End Function" & vbNewLine
component.CodeModule.DeleteLines 1, component.CodeModule.CountOfLines
component.CodeModule.AddFromString content
End Sub
Private Sub DestroyAnonymousMethod()
Dim component As VBComponent
Set component = Application.VBE.VBProjects("Reflection").VBComponents("AnonymousCode")
component.CodeModule.DeleteLines 1, component.CodeModule.CountOfLines
End Sub
You'll want to change the VBProjects("Reflection").VBComponents("AnonymousCode") to point to some empty standard module in your VBA project... or have a project named Reflection with an empty standard module named AnonymousCode for the Execute method to generate the function into.
As an artifact of how VBA code is compiled, the generated code can be executed, but you can't place a breakpoint in it, and the VBE will refuse to break inside the generated code - so whatever string you supply the factory method with, you better be sure it's simple enough to be 100% bug-free.
What this gives you, is an object that encapsulates a specific action: this object can then be passed around as a parameter, like any other object - so if you have your own collection class implementation (here LinqEnumerable), then you can use it to implement a Where method that takes a Delegate parameter, assuming the predicate parameter encapsulates a function that returns a Boolean:
Public Function Where(ByVal predicate As Delegate) As LinqEnumerable
Dim result As LinqEnumerable
Set result = New LinqEnumerable
Dim element As Variant
For Each element In encapsulated
If predicate.Execute(element) Then result.Add element
Next
Set Where = result
End Function
So given that custom collection class, you can create a Delegate instance that defines your custom criteria, pass it to the Where method, and get the filtered results back.
You can even push it further and implement an Aggregate method:
Public Function Aggregate(ByVal accumulator As Delegate) As Variant
Dim result As Variant
Dim isFirst As Boolean
Dim value As Variant
For Each value In encapsulated
If isFirst Then
result = value
isFirst = False
Else
result = accumulator.Execute(result, value)
End If
Next
Aggregate = result
End Function
And run it pretty much as you would with C# LINQ, minus compile-time type safety and deferred execution:
Dim accumulator As Delegate
Set accumulator = Delegate.Create("(work,value) => value & "" "" & work")
Debug.Print LinqEnumerable.FromList(List.Create("the", "quick", "brown", "fox")) _
.Aggregate(accumulator)
Output:
fox brown quick the
This work was the basis of the Lambda stuff in the VBEX repository on GitHub (originally by Chris McClellan, co-founder of the Rubberduck project; most of the work can be credited to Philip Wales though) - a 100%-VBA project that gives you several other classes to play with. I'd encourage you to explore these and see if any of it is more appropriate for production use.
Thanks for setting this question. I had been planning blog entries on using features from C# in VBA and this question prompted me. I have written a comprehensive blog entry on this topic. (I've even made a Youtube video discussing the solution's source code).
My offered solution is to use C# to write a Class Library DLL that does COM interop. It subclasses a Generic List, it also has a lambda expression parser so VBA code can pass a lambda into a Where method and get a filtered list.
You didn't give a class in your question for us to experiment with. So, I will give a class here called CartesianPoint which ships an Angle method and a Magnitude method which we can use the filter on. The class also implements IComparable so it can participate in sorting. The class implements an interface that is sufficient for it to run the lambda expressions.
Option Explicit
'written by S Meaden
Implements mscorlib.IComparable '* Tools->References->mscorlib
Implements LinqInVBA.ICartesianPoint
Dim PI
Public x As Double
Public y As Double
Public Function Magnitude() As Double
Magnitude = Sqr(x * x + y * y)
End Function
Public Function Angle() As Double
Angle = WorksheetFunction.Atan2(x, y)
End Function
Public Function AngleInDegrees() As Double
AngleInDegrees = Me.Angle * (360 / (2 * PI))
End Function
Private Sub Class_Initialize()
PI = 4 * Atn(1)
End Sub
Private Function ICartesianPoint_AngleInDegrees() As Double
ICartesianPoint_AngleInDegrees = Me.AngleInDegrees
End Function
Private Function ICartesianPoint_Magnitude() As Double
ICartesianPoint_Magnitude = Me.Magnitude
End Function
Private Property Get ICartesianPoint_ToString() As String
ICartesianPoint_ToString = ToString
End Property
Private Function IComparable_CompareTo(ByVal obj As Variant) As Long
Dim oPoint2 As CartesianPoint
Set oPoint2 = obj
IComparable_CompareTo = Sgn(Me.Magnitude - oPoint2.Magnitude)
End Function
Public Function ToString() As String
ToString = "(" & x & "," & y & ")"
End Function
Public Function Equals(ByVal oPoint2 As CartesianPoint) As Boolean
Equals = oPoint2.Magnitude = Me.Magnitude
End Function
Private Property Get IToStringable_ToString() As String
IToStringable_ToString = ToString
End Property
Sample VBA client code is given by this test routine. SO highlights the lambda strings.
Public Sub TestObjects2()
Dim oList As LinqInVBA.ListOfPoints
Set oList = New LinqInVBA.ListOfPoints
Dim o(1 To 3) As CartesianPoint
Set o(1) = New CartesianPoint
o(1).x = 3: o(1).y = 4
Set o(2) = New CartesianPoint
o(2).x = 0.25: o(2).y = 0.5
Debug.Assert o(2).Magnitude <= 1
Set o(3) = New CartesianPoint
o(3).x = -0.25: o(3).y = 0.5
Debug.Assert o(3).Magnitude <= 1
oList.Add o(1)
oList.Add o(2)
oList.Add o(3)
Debug.Print oList.ToString2 'prints (3,4),(0.25,0.5),(-0.25,0.5)
oList.Sort
Debug.Print oList.ToString2 'prints (-0.25,0.5),(0.25,0.5),(3,4)
Dim oFiltered As LinqInVBA.ListOfPoints
Set oFiltered = oList.Where("(o)=>o.Magnitude() <= 1")
Debug.Print oFiltered.ToString2 'prints (-0.25,0.5),(0.25,0.5)
Dim oFiltered2 As LinqInVBA.ListOfPoints
Set oFiltered2 = oFiltered.Where("(o)=>o.AngleInDegrees()>=0 && o.AngleInDegrees()<=90")
Debug.Print oFiltered2.ToString2 'prints (0.25,0.5)
' Dim i
' For i = 0 To oFiltered.Count - 1
' Debug.Print oFiltered.Item(i).ToString
' Next i
End Sub
The (shortened) C# code is given here
using System;
using System.Collections.Generic;
using System.Linq;
using System.Linq.Expressions;
using System.Runtime.InteropServices;
using myAlias = System.Linq.Dynamic; //install package 'System.Linq.Dynamic' v.1.0.7 with NuGet
//https://stackoverflow.com/questions/49453260/datastructure-for-both-sorting-and-filtering/49453892
//https://www.codeproject.com/Articles/17575/Lambda-Expressions-and-Expression-Trees-An-Introdu
//https://stackoverflow.com/questions/821365/how-to-convert-a-string-to-its-equivalent-linq-expression-tree
//https://stackoverflow.com/questions/33176803/linq-dynamic-parselambda-not-resolving
//https://www.codeproject.com/Articles/74018/How-to-Parse-and-Convert-a-Delegate-into-an-Expres
//https://stackoverflow.com/questions/30916432/how-to-call-a-lambda-using-linq-expression-trees-in-c-sharp-net
namespace LinqInVBA
{
// in project properties, build tab, check the checkbox "Register for Interop", run Visualstudio in admin so it can registers changes
// in AssemblyInfo.cs change to [assembly: ComVisible(true)]
public class LambdaExpressionHelper
{
public Delegate ParseAndCompile(string wholeLambda, int expectedParamsCount, Type[] paramtypes)
{
string[] split0 = wholeLambda.Split(new string[] { "=>" }, StringSplitOptions.None);
if (split0.Length == 1) { throw new Exception($"#Could not find arrow operator in expression {wholeLambda}!"); }
if (split0.Length != 2) { throw new Exception($"#Expecting only single arrow operator not {split0.Length - 1}!"); }
string[] args = split0[0].Trim().Split(new char[] { '(', ',', ')' }, StringSplitOptions.RemoveEmptyEntries);
if (args.Length != expectedParamsCount) { throw new Exception($"#Paramtypes array is of different length {expectedParamsCount} to argument list length{args.Length}"); }
var expression = split0[1];
List<ParameterExpression> pList = new List<ParameterExpression>();
for (int lArgLoop = 0; lArgLoop < args.Length; lArgLoop++)
{
Type typLoop = paramtypes[lArgLoop];
var p = Expression.Parameter(typLoop, args[lArgLoop]);
pList.Add(p);
}
var e = myAlias.DynamicExpression.ParseLambda(pList.ToArray(), null, expression);
return e.Compile();
}
}
public interface IFilterableListOfPoints
{
void Add(ICartesianPoint x);
string ToString2();
IFilterableListOfPoints Where(string lambda);
int Count();
ICartesianPoint Item(int idx);
void Sort();
}
public interface ICartesianPoint
{
string ToString();
double Magnitude();
double AngleInDegrees();
// add more here if you intend to use them in a lambda expression
}
[ClassInterface(ClassInterfaceType.None)]
[ComDefaultInterface(typeof(IFilterableListOfPoints))]
public class ListOfPoints : IFilterableListOfPoints
{
private List<ICartesianPoint> myList = new List<ICartesianPoint>();
public List<ICartesianPoint> MyList { get { return this.myList; } set { this.myList = value; } }
void IFilterableListOfPoints.Add(ICartesianPoint x)
{
myList.Add(x);
}
int IFilterableListOfPoints.Count()
{
return myList.Count();
}
ICartesianPoint IFilterableListOfPoints.Item(int idx)
{
return myList[idx];
}
void IFilterableListOfPoints.Sort()
{
myList.Sort();
}
string IFilterableListOfPoints.ToString2()
{
List<string> toStrings = new List<string>();
foreach (ICartesianPoint obj in myList)
{
toStrings.Add(obj.ToString());
}
return string.Join(",", toStrings.ToArray());
}
IFilterableListOfPoints IFilterableListOfPoints.Where(string wholeLambda)
{
Type[] paramtypes = { typeof(ICartesianPoint) };
LambdaExpressionHelper lh = new LambdaExpressionHelper();
Delegate compiled = lh.ParseAndCompile(wholeLambda, 1, paramtypes);
System.Func<ICartesianPoint, bool> pred = (System.Func<ICartesianPoint, bool>)compiled;
ListOfPoints newList = new ListOfPoints();
newList.MyList = (List<ICartesianPoint>)myList.Where(pred).ToList();
return newList;
}
}
}
Goal
I have a chart in Excel and I'm trying to replicate the same chart in VB.Net. I can get the chart data to be inputted correctly. I don't know how to retrieve the equation and R² value in a VB.Net chart control, as shown in my Excel chart.
Current Problem
Here is the data that is gotten in my Excel graph and Vb.Net chart:
' X Y
'0.895, 120.1
'0.978, 160.1
'1.461, 240.1
'1.918, 320.1
'2.343, 400.2
'2.769, 480.2
'3.131, 560.2
'3.493, 640.3
'3.797, 720.3
'4.089, 800.3
I get the following result from this (Excel):
As you can see, I receive a formula y= 203.83x - 62.797 and R²=0.9949
I'm trying to get the same result in Vb.Net but I am unable to find where this data is stored.
Any ideas?
I finally figured out my issue. Here is the clsTrendline.vb that I fetched using the help of multiple people/threads/conversion websites/Excel help on this site.
Public Class Trendline
#Region "Variables"
Private m_Slope As Decimal
Private m_Intercept As Decimal
Private m_Start As Decimal
Private m_End As Decimal
Private m_RSquared As Decimal
#End Region
#Region "Properties"
Public Property Slope() As Decimal
Get
Return m_Slope
End Get
Private Set
m_Slope = Value
End Set
End Property
Public Property Intercept() As Decimal
Get
Return m_Intercept
End Get
Private Set
m_Intercept = Value
End Set
End Property
Public Property Start() As Decimal
Get
Return m_Start
End Get
Private Set
m_Start = Value
End Set
End Property
Public Property [End]() As Decimal
Get
Return m_End
End Get
Private Set
m_End = Value
End Set
End Property
Public Property RSquared As Decimal
Get
Return m_RSquared
End Get
Set(value As Decimal)
m_RSquared = value
End Set
End Property
#End Region
#Region "New..."
Public Sub New(yAxisValues As IList(Of Decimal), xAxisValues As IList(Of Decimal))
Me.New(yAxisValues.[Select](Function(t, i) New Tuple(Of Decimal, Decimal)(xAxisValues(i), t)))
End Sub
Public Sub New(data As IEnumerable(Of Tuple(Of [Decimal], [Decimal])))
Dim cachedData = data.ToList()
Dim n = cachedData.Count
Dim sumX = cachedData.Sum(Function(x) x.Item1)
Dim sumX2 = cachedData.Sum(Function(x) x.Item1 * x.Item1)
Dim sumY = cachedData.Sum(Function(x) x.Item2)
Dim sumY2 = cachedData.Sum(Function(x) x.Item2 * x.Item2)
Dim sumXY = cachedData.Sum(Function(x) x.Item1 * x.Item2)
'b = (sum(x*y) - sum(x)sum(y)/n)
' / (sum(x^2) - sum(x)^2/n)
Slope = (sumXY - ((sumX * sumY) / n)) / (sumX2 - (sumX * sumX / n))
'a = sum(y)/n - b(sum(x)/n)
Intercept = (sumY / n) - (Slope * (sumX / n))
' r = (n * (Exy) - (Ex * Ey)) / (((n * (Ex2) - (Ex) ^ 2) ^ (1 / 2)) * ((n * (Ey2) - (Ey) ^ 2) ^ (1 / 2)))
RSquared = ((n * (sumXY) - (sumX * sumY)) / (((n * (sumX2) - (sumX) ^ 2) ^ (1 / 2)) * ((n * (sumY2) - (sumY) ^ 2) ^ (1 / 2)))) ^ 2
Start = GetYValue(cachedData.Min(Function(a) a.Item1))
[End] = GetYValue(cachedData.Max(Function(a) a.Item1))
End Sub
#End Region
#Region "Methods / Functions"
Public Function GetYValue(xValue As Decimal) As Decimal
Return Intercept + Slope * xValue
End Function
#End Region
End Class
Hopefully this will help someone!
I have my own macro defined in the Sheet1, for example:
Function MyPower(rad As Double) As Double
Dim res As Double
If rad = 0 Then
res = 0
Else
res = 0.01 * Exp(1.7 * Log(rad))
Power = res
End If
End Function
I want to be able to invoke it via a formula bar like one of the standard functions, i.e. fx = MyPower("A1"), the same way as fx = Cos("A1"), for example.
What do I need to do to add this macro to a formula bar? I am sure it's very simple, but it does not work by default.
Simple! Create your function in a Module instead of a Sheet macro.
You also mis-placed and mis-typed the return value...
Function MyPower(rad As Double) As Double
Dim res As Double
If rad = 0 Then
res = 0
Else
res = 0.01 * Exp(1.7 * Log(rad))
End If
MyPower = res ' <-- "MyPower": Move it here
End Function
I am using the fts4 extension of sqlite3 to enable full-text indexing and searching of text data. This it working great, but I've noticed that the results are not relevance-ranked at all. I guess I am too used to Lucene. I've seen some brief suggestions to write a custom rank method using the matchinfo() results, but it's not clear to me how this is done, or whether there are any sophisticated examples out there. How have others dealt with this?
There's a complete example in the documentation, look at the end of appendix a. You'll need to do slightly more work to get a good relevance ranking as the function provided is good only for getting started. For example, with matchinfo(table,'pcnalx') there's enough information to implement Okapi BM25.
There seems to be a distinct lack of documentation on how to implement Okapi BM25 in C and it seems it is an unspoken thing that the implementation is left as an exercise for the user.
Well I found the bro of a programmer "Radford 'rads' Smith" who chucked this up on GitHub
https://github.com/rads/sqlite-okapi-bm25
It only implements BM25 although I'm looking into BM25F tweaks now....
....and here it is.
https://github.com/neozenith/sqlite-okapi-bm25
For FTS5, according to SQLite FTS5 Extension,
FTS5 has no matchinfo().
FTS5 supports ORDER BY rank
So very simply, something like
SELECT * FROM email WHERE email MATCH 'fts5' ORDER BY rank;
without DESC works.
Here is an implementation of Okapi BM25. Using this in combination with the suggestions at SQLite.org will help you generate a relevance-ranked MATCH query. This was written all in VB.Net and the query was called using System.Data.SQLite functions. The custom SQLiteFunction at the end can be called from the SQL code without issue, as long as the SQL code is called using System.Data.SQLite functions.
Public Class MatchInfo
Property matchablePhrases As Integer
Property userDefinedColumns As Integer
Property totalDocuments As Integer
Private _int32HitData As List(Of Integer)
Private _longestSubsequencePhraseMatches As New List(Of Integer)
Private _tokensInDocument As New List(Of Integer)
Private _averageTokensInDocument As New List(Of Integer)
Private _max_hits_this_row As Integer?
Public ReadOnly Property max_hits_this_row As Integer
Get
If _max_hits_this_row Is Nothing Then
_max_hits_this_row = 0
For p = 0 To matchablePhrases - 1
For c = 0 To userDefinedColumns - 1
Dim myHitsThisRow As Integer = hits_this_row(p, c)
If myHitsThisRow > _max_hits_this_row Then
_max_hits_this_row = myHitsThisRow
End If
Next
Next
End If
Return _max_hits_this_row
End Get
End Property
Private _max_hits_all_rows As Integer?
Public ReadOnly Property max_hits_all_rows As Integer
Get
If _max_hits_all_rows Is Nothing Then
_max_hits_all_rows = 0
For p = 0 To matchablePhrases - 1
For c = 0 To userDefinedColumns - 1
Dim myHitsAllRows As Integer = hits_all_rows(p, c)
If myHitsAllRows > _max_hits_all_rows Then
_max_hits_all_rows = myHitsAllRows
End If
Next
Next
End If
Return _max_hits_all_rows
End Get
End Property
Private _max_docs_with_hits As Integer?
Public ReadOnly Property max_docs_with_hits As Integer
Get
If _max_docs_with_hits Is Nothing Then
_max_docs_with_hits = 0
For p = 0 To matchablePhrases - 1
For c = 0 To userDefinedColumns - 1
Dim myDocsWithHits As Integer = docs_with_hits(p, c)
If myDocsWithHits > _max_docs_with_hits Then
_max_docs_with_hits = myDocsWithHits
End If
Next
Next
End If
Return _max_docs_with_hits
End Get
End Property
Private _BM25Rank As Double?
Public ReadOnly Property BM25Rank As Double
Get
If _BM25Rank Is Nothing Then
_BM25Rank = 0
'calculate BM25 Rank
'http://en.wikipedia.org/wiki/Okapi_BM25
'k1, calibrates the document term frequency scaling. Having k1 as 0 corresponds to a binary model – no term frequency. Increasing k1 will give rare words more boost.
'b, calibrates the scaling by document length, and can take values from 0 to 1, where having 0 means no length normalization and having 1 corresponds to fully scaling the term weight by the document length.
Dim k1 As Double = 1.2
Dim b As Double = 0.75
For column = 0 To userDefinedColumns - 1
For phrase = 0 To matchablePhrases - 1
Dim IDF As Double = Math.Log((totalDocuments - hits_all_rows(phrase, column) + 0.5) / (hits_all_rows(phrase, column) + 0.5))
Dim score As Double = (IDF * ((hits_this_row(phrase, column) * (k1 + 1)) / (hits_this_row(phrase, column) + k1 * (1 - b + b * _tokensInDocument(column) / _averageTokensInDocument(column)))))
If score < 0 Then
score = 0
End If
_BM25Rank += score
Next
Next
End If
Return _BM25Rank
End Get
End Property
Public Sub New(raw_pcnalsx_MatchInfo As Byte())
Dim int32_pcsx_MatchInfo As New List(Of Integer)
For i = 0 To raw_pcnalsx_MatchInfo.Length - 1 Step 4
int32_pcsx_MatchInfo.Add(BitConverter.ToUInt32(raw_pcnalsx_MatchInfo, i))
Next
'take the raw data and parse it out
Me.matchablePhrases = int32_pcsx_MatchInfo(0)
int32_pcsx_MatchInfo.RemoveAt(0)
Me.userDefinedColumns = int32_pcsx_MatchInfo(0)
int32_pcsx_MatchInfo.RemoveAt(0)
Me.totalDocuments = int32_pcsx_MatchInfo(0)
int32_pcsx_MatchInfo.RemoveAt(0)
'remember that the columns are 0-based
For i = 0 To userDefinedColumns - 1
_averageTokensInDocument.Add(int32_pcsx_MatchInfo(0))
int32_pcsx_MatchInfo.RemoveAt(0)
Next
For i = 0 To userDefinedColumns - 1
_tokensInDocument.Add(int32_pcsx_MatchInfo(0))
int32_pcsx_MatchInfo.RemoveAt(0)
Next
For i = 0 To userDefinedColumns - 1
_longestSubsequencePhraseMatches.Add(int32_pcsx_MatchInfo(0))
int32_pcsx_MatchInfo.RemoveAt(0)
Next
_int32HitData = New List(Of Integer)(int32_pcsx_MatchInfo)
End Sub
Public Function hits_this_row(phrase As Integer, column As Integer) As Integer
Return _int32HitData(3 * (column + phrase * userDefinedColumns) + 0)
End Function
Public Function hits_all_rows(phrase As Integer, column As Integer) As Integer
Return _int32HitData(3 * (column + phrase * userDefinedColumns) + 1)
End Function
Public Function docs_with_hits(phrase As Integer, column As Integer) As Integer
Return _int32HitData(3 * (column + phrase * userDefinedColumns) + 2)
End Function
End Class
<SQLiteFunction("Rank", 1, FunctionType.Scalar)>
Public Class Rank
Inherits SQLiteFunction
Public Overrides Function Invoke(args() As Object) As Object
Return New MatchInfo(args(0)).BM25Rank
End Function
End Class