Большой массив с заданным пользователем количеством измерений

Question

Недавно я написал question с просьбой о помощи в подсчете количества случаев появления каждой уникальной пары аллергий в популяции. Решения, которые я получил, были замечательными, однако теперь мне нужно посмотреть на комбинации 3+ аллергии, и все это с помощью таблиц Excel займет много времени.

Я решил написать скрипт VBA для этого, который отлично подходит для пар. Это также намного быстрее, так как я вернулся и изменил формат исходных данных, чтобы каждый связанный с AllExceptionID атрибут ExceptionID хранился в одной строке с разделителями-запятыми.

Теперь я смотрю на перемещение вверх к массиву 3D или выше, и поскольку мы не знаем, сколько измерений нам нужно будет поднимать (возможно, 10 или 15), я бы предпочел избежать использования ряда Case или вложенные If/Then заявления.

Моих исследований оказалось this article, в котором я понял, что я спрашиваю, практически невозможно, но я хотел бы спросить о заявлении, что ФП, что

Я думал, что можно было бы сделать, если бы я может построить оператор Redim во время выполнения в виде строки и выполнить строку, но это не представляется возможным.

У меня в основном была та же идея. В приведенном ниже коде генерируется ошибка несоответствия типа, но нет ли изменений в этом, которые могут работать? Можем ли мы не передавать другие функции (например, join) внутри ReDim?

Sub testroutine() 

Dim x As Integer, y As Integer 'just a counter 
Dim PairCount() As String 
Dim AllergenRef As Object 'Object to store a reference to each AllergenID using AllergenKey as key 
    Set AllergenRef = CreateObject("Scripting.Dictionary") 

For x = 1 To 20 
    AllergenRef.Add x, (x * 10) + (2^x) 'dummy data for my dictionary 
Next x 

Dim N_tuple As Integer 
N_tuple = 5 'this value would be provided by a user form at runtime 
Dim ArrayDim() As String 
ReDim ArrayDim(1 To N_tuple) 

For x = 1 To N_tuple 

    ArrayDim(x) = "1 to " & AllergenRef.Count 

Next x 

ReDim PairCount(Join(ArrayDim, ",")) 'This is the line that throws an error 

End Sub 

This article делает это звучит как то, что я делаю, это возможно в Java, но я не говорю по-яванского, так что я не могу сказать, как это похоже на то, что я пытаюсь достичь, или если есть способ применить этот метод к VBA ...

ОБНОВЛЕНИЕ ============
Вот образец данных I ' m с использованием (в отдельных колонках я добавил черточки для ясности)

ExceptionID - ExcAllergens
035 - 100380
076 - 100107,100392,100345,100596,100141,100151,100344
200 - 100123,100200
325 - 100381
354 - 100381,10 355 - 100381,10 360 - 100586
390 - 100151,100344,100345,100349
441 - 100380,100368
448 - 100021,100181,100345,100200,100344,100295
491 - 100381
499 - 100333
503 - 100333
507 - 100331,100346,100596,100345,100344,100269,100283

А вот отрывок из таблицы определений аллергена (аллерген ключ что-то я просто добавил так, чтобы иметь меньшие числа для работы, 6-значные числа - это то, что используется в нашей БД.)

AllergenKey - AllergenID - AllergenTag
01 - 100011 - ягоды асаи
02 - 100012 - уксусная кислота
03 - 100013 - Агар Агар
04 - 100014 - Агава
05 - 100015 - Алкоголь
06 - 100016 - Душистый
07 - 100017 - Аммоний Бикарбонат
08 - 100018 - Амилаза
09 - 100019 - Аннатто
10 - 100020 - Apple
11 - 100021 - Apple, Сырье
12 - 100022 - абрикос
13 - 100023 - Маранта
14 - 100025 - Аскорбиновая кислота
15 - 100027 - спаржа
16 - 100028 - Авокадо
17 - 100029 - бактериальная культура
18 - 100030 - Разрыхлитель

Обратите внимание, что есть 6810 профили исключения, начиная сюда от 1 до 51 раздельных аллергий (в среднем около 4 или 5) и 451 различных аллергенов. Вот результат моего анализа пар аллергена (кстати, когда я говорю «Аллерген» также включает в себя диетические предпочтения, как вегетарианец):

Топ 10 пара - пара графа - Аллерген 1 - аллерген 2
1 - 245 - Молочная - Клейковина
2 - 232 - Яйца - Гайки
3 - 190 - Молочная - Яйца
4 - 173 - Клейковина - Овес
5 - 146 - Соевый (может содержать) - Соевый
6 - 141 - Молочные продукты - Орехи
7 - 136 - Говядина - свинина
8 - 120 - Молочная - Соевый
9 - 114 - Сезам (могут содержать) - Гайки
10 - 111 - Вегетарианская 1 - Свинина

Answer 1

Я Wouldnt»беспокоиться о максимальных возможных комбинациях с вашими средними данными. Вы не сможете сделать все возможные комбинации. У вас будет много комбинаций, которые не будут встречаться в выборке. Не пытайтесь вычислить их все, а затем посчитайте вхождения.

Вместо этого проведите свою выборочную совокупность и создайте кортежи как записи данных на листе «массив». Я предлагаю использовать 3-значный ключ аллергена в качестве номеров идентификаторов и объединить числа в кортежах Long (возможно, десятичное число может понадобиться для больших чисел).

Подход, который я предлагаю, заключается в объединении кортежей в виде длин, которые можно легко разложить позже. Затем используйте частотную функцию для подсчета вхождений каждого набора «число».поэтому, если есть аллергены с ключами: 1, 17, 451 - они образуют составную часть длиной 1 017 451 (идентично 451, 17, & 1) - мы гарантируем, что любой кортеж заставил порядок наименьшего ключа до самого большого ключа. Таким образом, максимальная тройка составляет 449 450 451, а самая маленькая - 1002 003. Обратите внимание, что вы НИКОГДА не имеете 3,002,001, так как это будет дублировать 1 002 003.

Модуль я имел игру с ниже: EDIT - для лучшего кода

Option Explicit 
Option Base 1 

Public Function concID(paramArr() As Variant) As Variant 
' this function takes an array of numbers and arranges the array into 
' one long code number - with order of smallest to largest 
' the code number generated has each individual array entry as a 3-digit component 

    Dim wsf As WorksheetFunction 
    Dim decExp As Integer 
    Dim i As Long, j As Long 
    Dim bigNum As Variant ' may need to cast to Decimal?? 

    Set wsf = WorksheetFunction 

    'may use cDec if necessary here?? 
    For i = 1 To UBound(paramArr) 
     'determine the position of the component by multiplying by a multiple of 10^3 
     decExp = 3 * (UBound(paramArr) - i) 
     bigNum = bigNum + wsf.Small(paramArr, i) * 10^decExp 
    Next i 
    concID = bigNum 

End Function 

Public Sub runAllergen() 

    Dim ws As Worksheet 
    Dim dataRange As Range, tupleRange As Range, uniqueList As Range, freqRange As Range, r As Range 
    Dim i As Long, j As Long, counter As Long 
    Dim dataArray As Variant, arr As Variant, tempholder As Long 
    Dim bigArray(1 To 10^6, 1 To 1) As Variant ' the array which will hold all the generated combinations from the data 
    Dim tuple As Long 

    tuple = 3 
    'this will come in as a user input. 
    Set ws = Sheet1 
    Set dataRange = ws.Range("A2:A10001")  'I have 10k people in my dataset, and this is just the allergen data vector 

    Application.ScreenUpdating = False 'IMPORTANT for efficiency 

    tempholder = 1 'this is the array index which the next combi entry is to be put into bigArray 
    dataArray = dataRange.Value 'write entire worksheet column to internal array for efficiency 
    For i = 1 To UBound(dataArray) 
     'obtain array of allergen values in each data row to obtain tuples from 
     arr = Split(dataArray(i, 1), ",") 
     If UBound(arr) + 1 >= tuple Then 
       'give over the array of row data to make tuples from and write to bigArray 
       'return the next available index of bigArray to store data 
       tempholder = printCombinations(arr, tuple, bigArray(), tempholder) 
     End If 
    Next i 

    Set r = ws.Range("B2") 
    'write entire list of tuples from data population to worksheet for efficiency - MASSIVE performance boost 
    r.Resize(tempholder - 1, 1).Value = bigArray 
    'copy tuple output over to another column to remove duplicates and get unique list 
    Set tupleRange = ws.Range(r, r.End(xlDown)) 
    tupleRange.Copy 
    Set r = ws.Range("D2") 
    r.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 
    :=False, Transpose:=False 

    'remove duplicates from copied tuple output to get a unique list of codes to serve as bins in FREQUENCY function 
    ws.Range(r, r.End(xlDown)).RemoveDuplicates Columns:=1, Header:=xlNo 
    Set uniqueList = ws.Range(r, r.End(xlDown)) 
    Application.CutCopyMode = False 
    'set the frquency output range which is always 1 more row than the bins array 
    Set freqRange = uniqueList.Offset(0, 1).Resize(uniqueList.Rows.Count + 1, 1) 
    'get the frequency of each tuple 
    freqRange.FormulaArray = "=FREQUENCY(R2C" & tupleRange.Column & ":R" & tupleRange.Rows.Count + 1 & _ 
        "C" & tupleRange.Column & _ 
        ",R2C" & uniqueList.Column & ":R" & uniqueList.Rows.Count + 1 & "C" & uniqueList.Column & ")" 

    Application.ScreenUpdating = True 
End Sub 

Public Function printCombinations(pool As Variant, r As Long, printVector As Variant, tempPosition As Long) As Long 

    'this function writes the data row arrays as tuples/combis to the bigArray, 
    'and returns the next available index in bigArray 
    Dim i As Long, j As Long, n As Long 
    Dim tempholder() As Variant 
    Dim idx() As Long 

    ReDim tempholder(1 To r) 
    ReDim idx(1 To r) 

    n = UBound(pool) - LBound(pool) + 1 
    For i = 1 To r 
     idx(i) = i 
    Next i 

    Do 
     For j = 1 To r 
       tempholder(j) = CLng(pool(idx(j) - 1)) 
     Next j 

     'we now have an array of size tuple from the row data, so construct our code number, 
     'and write to the next available index in bigArray 

     printVector(tempPosition, 1) = concID(tempholder) 
     tempPosition = tempPosition + 1 

     ' Locate last non-max index 
     i = r 
     While (idx(i) = n - r + i) 
       i = i - 1 
       If i = 0 Then 
        'the algorithm has ended with the last index exhausted 
        'return the next available index of bigArray 
        printCombinations = tempPosition 
        Exit Function 
       End If 
     Wend 

     idx(i) = idx(i) + 1 
     For j = i + 1 To r 
       idx(j) = idx(i) + j - i 
     Next j 
    Loop 

End Function 

Начальная установка:

Вы можете также скопировать оклеивать ваш диапазон частот в значения и т. д.

Answer 2

Чтобы расширить мой комментарий, вот некоторые модифицированный код для использования массив массивов на основе предоставленной переменной N_tuple. Я с большим трудом представляя себе ситуацию, когда это не будет работать для вас:

Sub testroutine() 

Dim x As Integer, y As Integer 'just a counter 
Dim ArrayTemp() As Variant 
Dim PairCount() As Variant 
Dim AllergenRef As Object 'Object to store a reference to each AllergenID using AllergenKey as key 
    Set AllergenRef = CreateObject("Scripting.Dictionary") 

For x = 1 To 20 
    AllergenRef.Add x, (x * 10) + (2^x) 'dummy data for my dictionary 
Next x 

Dim N_tuple As Integer 
N_tuple = 5 'this value would be provided by a user form at runtime 

'Now that you have your N_tuple, redim your paircount array 
ReDim PairCount(1 To N_tuple) 

'For each N_tuple, create an array and add it to the PairCount array 
'Note that you could easily have a 2-dimensional array for a table of values as ArrayTemp 
For x = 1 To N_tuple 
    ReDim ArrayTemp(1 To AllergenRef.Count) 
    PairCount(x) = ArrayTemp 
Next x 

'Now you have an array of arrays, which can be easily accessed. 
'For example: PairCount(2)(3) 
'Or if the subarrays are 2-dimensional: PairCount(4)(6, 12) 

'This simply loops through the PairCount array and shows the ubound of its subarrays 
For x = 1 To UBound(PairCount) 
    MsgBox UBound(PairCount(x)) 
Next x 

End Sub