Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1 2 След.
RSS
Поиск консенсусной последовательности
 
#1
13.11.2023 10:20:24
Добрый утро всем любителям эксель! Помогите решить следующую задачу: необходимо найти наиболее общую (консенсусную) последовательность, то есть нужно сравнить поочередно все буквы в каждой позиции нескольких ячеек и вернуть букву которая наиболее частов стречается в каждой позиции. Пример прилагаю. Если разных букв в какой-либо позиции одинаковое число, как в примере в самом конце, то можно оставить любую из них.
 
 
 
#2
13.11.2023 10:42:50
Поясните, а для буквы G какой результат (сколько раз она встречается)? 4?

Вот как понял посчитал (не проблема вывести букву с макс значением), посмотрите на подсчет. Верен?
PQ:
Код
let
  data = Excel.CurrentWorkbook(){[ Name = "data" ]}[Content],
  find = Excel.CurrentWorkbook(){[ Name = "find" ]}[Content],
  transform = Table.FromList (
    List.Select (
      List.Transform ( List.Zip ( List.Transform ( data[Дано] & find[Найти], Text.ToList ) ), List.Distinct ),
      ( x ) => List.Count ( x ) = 1
    ),
    ( x ) => x,
    type table [ Буква = text ]
  ),
  group = Table.Group ( transform, { "Буква" }, { { "Количество", each Table.RowCount ( _ ), Int64.Type } } ),
  sort = Table.Sort ( group, { { "Количество", Order.Descending } } )
in
  sort
 
 
 
#3
13.11.2023 10:54:09
surkenny, немного не то. Нужно не количество букв во всех строках посчитать, а найти последовательность которая показана в ячейке А8, взяв данные из A2:A5. Например в A2:A5 первая буква "M", значит в А8 первая "М", и т.д., в 9-ой позиции в трех строках "G" в одной "A", "G" букв больше, значит "G" и т.д. Можно плиз либо формулой, либо пользовательской функцией, для PQ я ещё не дорос, разве что другим пригодится.
 
 
 
#4
13.11.2023 11:02:07

dim284 Здравствуйте А потом будем в надстройку решение запихивать?
 
 
 
#5
13.11.2023 11:25:33
В виде UDF. В качестве входного аргумента должен быть одностолбиковый диапазон (как в примере)
Код
Function Консенсус(rngIn As Range) As String
    Dim arrIn(), i&, j&, Cnt&, CntPos&, Char$
    
    arrIn = rngIn.Value
    CntPos = Len(arrIn(1, 1))
    Cnt = UBound(arrIn)
    Консенсус = String(CntPos, vbNullChar)
    Char = String(1, vbNullChar)
    
    With CreateObject("Scripting.Dictionary")
        For i = 1 To CntPos
            For j = 1 To Cnt
                LSet Char = Mid$(arrIn(j, 1), i, 1)
                .Item(Char) = .Item(Char) + 1
            Next
            Mid$(Консенсус, i, 1) = .Keys()(GetIndexOfMax(.Items))
            .RemoveAll
        Next
    End With
End Function

Private Function GetIndexOfMax(arr) As Long
    Dim i&
    For i = 1 To UBound(arr)
        If arr(i - 1) < arr(i) Then
            GetIndexOfMax = i
        End If
    Next
End Function
Изменено: testuser - 14.11.2023 02:32:44
 
 
 
#6
13.11.2023 11:59:34
testuser, здравствуйте! Спасибо большое, замечательно работает!
Евгений Смирнов, добрый день! Конечно, так же намного удобнее чем каждый раз создавать файл xlsm и из вордовского документа перекопировать все макросы и функции, я так первый год делал, это был кошмар. Надстройка - это очень удобный способ хранения всех процедур и сделать то её легко, особо учится не надо, рисуй себе кнопочки как у других... Ещё хорошо что в интернете много готового есть, на русском языке столько всего не перечитать, неговоря про англоязычные сайты, этим эксель хорош. Надстройка не в коем случае не продажи, а для работы, с белковыми и нуклеотидными последовательностями.
 
 
 
#7
13.11.2023 12:19:13
Мой вариант тоже проверите?
Код
Function StrVih(Rg1 As Range) As String
Dim Arr1, Tp1, kCel&, kSim&, Max1&, Max2&, Str1$
Arr1 = Rg1.Value
kSim = VBA.Len(Arr1(1, 1))
kCel = UBound(Arr1, 1)
ReDim Tp1(1 To kCel)
For j = 1 To kSim
    For i = 1 To kCel
Tp1(i) = VBA.Mid(Arr1(i, 1), j, 1)
    Next
    Str1 = "": Max2 = 0
    For i = 1 To kCel
Max1 = UBound(VBA.Filter(Tp1, Tp1(i), 1, 1))
If Max1 > Max2 Then Max2 = Max1: Str1 = Tp1(i)
    Next
    StrVih = StrVih & Str1
Next
End Function
 
 
 
#8
13.11.2023 12:45:21
Евгений, Вы великолепны, как всегда! Код функции короче, состоит из одной функции (без вложенных в неё функций) и, самое главное, работает в 3,25 раз быстрее. Ну, теперь любой человек может стать биоинформатиком.
 
 
 
#9
13.11.2023 12:48:23
dim284 Очень приятно, что вам понравилось.
В спешке не объявил счетчики i J как Long, что не правильно. Исправьте.
Изменено: Евгений Смирнов - 13.11.2023 13:03:43
 
 
 
#10
13.11.2023 13:53:23
Правильно?
Код
Function Консенсус(Rg1 As Range) As String
Dim Arr1, Tp1, kCel&, kSim&, Max1&, Max2&, Str1$
Dim i As Long
Dim j As Long
Arr1 = Rg1.Value
kSim = VBA.Len(Arr1(1, 1))
kCel = UBound(Arr1, 1)
ReDim Tp1(1 To kCel)
For j = 1 To kSim
    For i = 1 To kCel
Tp1(i) = VBA.Mid(Arr1(i, 1), j, 1)
    Next
    Str1 = "": Max2 = 0
    For i = 1 To kCel
Max1 = UBound(VBA.Filter(Tp1, Tp1(i), 1, 1))
If Max1 > Max2 Then Max2 = Max1: Str1 = Tp1(i)
    Next
    Консенсус = Консенсус & Str1
Next
End Function
 
 
 
#11
13.11.2023 15:12:59
dim284 Все верно. Теперь надо написать еще пару вариантов по другим алгоритмам и проверить скорость.
Можно проверить скорость.
Код
Function StrVih1(Rg1 As Range) As String
Dim Arr1, kCel&, kSim&, Max1&, Max2&, Str1$, Str2$, Str3$, i&, j&
Arr1 = Rg1.Value
kSim = VBA.Len(Arr1(1, 1))
kCel = UBound(Arr1, 1)
For j = 1 To kSim
Str1 = ""
    For i = 1 To kCel
Str1 = Str1 & VBA.Mid(Arr1(i, 1), j, 1)
    Next
Max2 = 0: Str3 = ""
    For i = 1 To kCel
Str2 = VBA.Mid(Str1, i, 1)
Max1 = VBA.Len(Str1) - VBA.Len(VBA.Replace(Str1, Str2, ""))
If Max1 > Max2 Then Max2 = Max1: Str3 = Str2
    Next
    StrVih1 = StrVih1 & Str3
Next
End Function
Изменено: Евгений Смирнов - 13.11.2023 16:28:28
 
 
 
#12
13.11.2023 17:13:58
Ну и последний вариант.
Код
Function StrVih2(Rg1 As Range) As String
Dim Arr1, Dic1, kCel&, kSim&, Max1&, Str1$, i&, j&
Set Dic1 = CreateObject("Scripting.Dictionary")
Arr1 = Rg1.Value
kSim = VBA.Len(Arr1(1, 1))
kCel = UBound(Arr1, 1)
For j = 1 To kSim
    For i = 1 To kCel
Str1 = VBA.Mid(Arr1(i, 1), j, 1)
If Dic1.exists(Str1) Then Dic1(Str1) = Dic1(Str1) + 1 Else Dic1(Str1) = 1
    Next
        Max1 = 0: Str1 = ""
    For i = 0 To Dic1.Count - 1
If Dic1.items()(i) > Max1 Then Max1 = Dic1.items()(i): Str1 = Dic1.keys()(i)
    Next
    Dic1.RemoveAll
    StrVih2 = StrVih2 & Str1
Next
End Function
 
 
 
#13
13.11.2023 17:50:49
Доброе время суток
surkenny, коллега, предполагаю, что имелось ввиду
Код
let
    source = Excel.CurrentWorkbook(){[Name="data"]}[Content],
    toList = List.Transform(Table.ToList(source), Text.ToList),
    toZip = List.Zip(toList),
    chars = List.Transform(toZip, each [
        toTable = Table.FromColumns({_}, {"f"}),
        defineCount = Table.Group(toTable, {"f"}, {"c", Table.RowCount}),
        defineMax = Table.Max(defineCount, "c")

    ][defineMax][f]),
    return = Text.Combine(chars)
in
    return
 
 
 
#14
14.11.2023 10:22:27
Итого: победитель функция StrVih1 из сообщения #11 - 0.05 мс, серебро StrVih из сообщения  #7 -  0,08 мс, бронза StrVih2 из сообщения  #12 - 0,29 мс.
С PQ не получается, возможно из-за того, что в коде все на английском, а у меня эсель русский, source в моем варианте Источник. В общем помучился немного, но ничего не получилось. Хотя обидно, можно было скорость сравнить, "Мерка 2.1" позволяет измерять скорость кодов PQ. Но что-то мне подсказывает, что это будет медленнее: пока загрузишь, пока выгрузишь, уже два действия :)  В любом случае спасибо Андрей VG, ещё пригодится!
 
 
 
#15
14.11.2023 10:53:20
Цитата
dim284: Итого: победитель
поверхностное сравнение со множеством неизвестных.
    Вот вам ещё функция. Она хуже на маленьком диапазоне и лучше на большом. По-хорошему, нужно сравнивать время обработки строк, а не диапазонов (собрать строковый массив и тестить на нём). В моей функции закомментирован доп. вариант ( на тесте дал то же время, но на чистых строках всё может измениться).
Код с тестами
Файл с кодом
Изменено: Jack Famous - 14.11.2023 10:53:43
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
 
 
#16
14.11.2023 11:37:13
Так, на вс. случай, если говорить о скорости, ели использовать "ранее связывание" функции, использующие словарь могут раскрыть себя немного иначе. Вообще, вариантов, может быть много конечно и без словаря (с ним прото всегда проще), тот же вариант с фильтром, если написать функцию фильтра на vba, может быть побыстрее (есть хорошая вероятность)..
Код
'Для работы требуется подключенный "Microsoft Scripting Runtime" (scrrun.dll)
Function TurboКонсенсус(rngIn As Range) As String
    Static Dict As New Dictionary
    Dim arrIn(), i&, j&, Cnt&, CntPos&, CntRws&, CntMax&, Char$, ChrMax$
    
    arrIn = rngIn.Value
    CntPos = Len(arrIn(1, 1))
    CntRws = UBound(arrIn)
    TurboКонсенсус = String(CntPos, vbNullChar)
    ChrMax = vbNullChar
    Char = vbNullChar
    
    With Dict
        For i = 1 To CntPos
            For j = 1 To CntRws
                LSet Char = Mid$(arrIn(j, 1), i, 1)
                Cnt = .Item(Char) + 1
                .Item(Char) = Cnt
                If CntMax < Cnt Then
                    CntMax = Cnt
                    LSet ChrMax = Char
                End If
            Next
            CntMax = 0
            Mid$(TurboКонсенсус, i, 1) = ChrMax
            .RemoveAll
        Next
    End With
End Function
Изменено: testuser - 14.11.2023 11:38:19
 
 
 
#17
14.11.2023 12:13:54
Если в моём методе ограничить массив символов до латиницы (Const symMax& = 122) то будет быстрее во всех случаях (ReDim большого массива ел всё время). Можно и не ограничивать, но тогда в памяти нужно будет хранить таких пустых массивов — по количеству символов в строке. Памяти хватит, но пока делать не стал. Сравнение по коду символа, как индексу массива всегда будет быстрее словаря, но, к сожалению, на VBA эти коды ещё нужно получить, а это время…
    Мой код работает со строками с разным количеством символов и есть проверка на ошибки и пустоты (наличие на время практически не влияет)
Код
P.S.: словари от Евгения Смирнова подключил.
Изменено: Jack Famous - 14.11.2023 13:10:39
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
 
 
#18
14.11.2023 12:18:04
Testuser Здравствуйте. Вчера вечером тоже потестил на скорость. Меня удивил значительный проигрыш варианта со словарем. Потом переписал со словаря на коллекции, код получился длиннее (с коллекцией проблематичнее в каких-то случаях работать), но по скорости близко ко 2 варианту (обработка строк). Вот это совсем непонятно.
Но при больших объемах данных для скорости надо наверно на байтовые массивы переходить. Но мне как  любителю, зачем этим голову забивать.
 
 
 
#19
14.11.2023 12:20:57
Цитата
Евгений Смирнов: переписал со словаря на коллекции
для данной задачи, коллекции хуже словаря в раннем связывании, т.к. работают медленнее до 100 тыс. ключей.

UPD: можно ещё на InStr сравнение сделать. Сейчас попробую
Изменено: Jack Famous - 14.11.2023 12:26:38
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
 
 
#20
14.11.2023 12:27:00
Jack Famous, я бы потестил функцию JF_MainString, но она у меня не работает?
 
 
 
#21
14.11.2023 12:34:29
Цитата
dim284: Jack Famous, я бы потестил функцию JF_MainString, но она у меня не работает?
я же файл прикрепил с ней в том числе. В нём всё должно работать.
    Да и вообще, она не требует подключения сторонних библиотек…
Добавил новую функцию, которая ещё быстрее

Цитата
Jack Famous: UPD: можно ещё на InStr сравнение сделать. Сейчас попробую
пока не буду. Нет времени и желания.
Изменено: Jack Famous - 14.11.2023 13:07:45
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
 
 
#22
14.11.2023 13:55:46
Файл и открываю, там ошибка знач, см. фото. А если использовать код из последнего сообщения, то эксель ругается на каждую строчку где написано "Dict As New Dictionary", см. скриншот.
Как бы там ни было, функция от Евгения замечательная и скорость вполне приличная чтобы работать с большими объемами данных.
 
 
 
#23
14.11.2023 13:56:40
Jack Famous, спасибо за тест, у вас как всегда зубодробительные стенды, с непонятными названиями )
Цитата
Евгений Смирнов написал:
Меня удивил значительный проигрыш варианта со словарем. Потом переписал со словаря на коллекции, код получился длиннее (с коллекцией проблематичнее в каких-то случаях работать), но по скорости близко ко 2 варианту (обработка строк).
Весь затык в позднем связывании. Здесь где-то был тест сравнения словаря и коллекции, из выводов утверждалось, что коллекции до определенных чисел проигрывают словарям, но после  выигрывают..
Цитата
Евгений Смирнов написал:
Но при больших объемах данных для скорости надо наверно на байтовые массивы переходить. Но мне как  любителю, зачем этим голову забивать.
Конечно, всегда есть еще вопрос потребности. А если, по случаю, и так хорошо, зачем делать лучше )
 
 
 
#24
14.11.2023 13:59:31
dim284, добавьте небольшой код для вызова на листе функции CallMe, т.к. я писал функцию для использования на VBA
Код
Function CallMe(rng As Range) As String
    JF_MainString_Matrix rng, CallMe
End Function

Цитата
dim284: эксель ругается на каждую строчку где написано "Dict As New Dictionary"
долго объяснять. Удалите функции с такими строчками или используйте их старые варианты. Это не мои функции.

Цитата
testuser:Jack Famous , спасибо за тест, у вас как всегда зубодробительные стенды, с непонятными названиями )
спасибо и вам за вариант. Правда, преимущество/необходимость LSet не заметил, но и не тестил детально.
    Сам тест имеет имя Test, EvSm это Евгений Смирнов, JF это Jack Famous, MainString это общая/обобщённая строка, Matrix это матрица. Надеюсь помог  ;)
    Стенд охватывает только разное количество ячеек диапазона. Как проверить более "правильно" — писал выше.
    Видел у вас фокусы с копированием памяти, но не видел тестов со штатными аналогами. Не хотите сделать? Мои пробы (не на вашем коде) не показали никакого ускорения… Возможно, кстати, копирование памяти может помочь в обнулении большого целочисленного одномерного массива (вместо ReDim) …
Изменено: Jack Famous - 14.11.2023 14:35:56
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
 
 
#25
14.11.2023 14:33:39
Цитата
dim284 написал:
эксель ругается на каждую строчку где написано "Dict As New Dictionary", см. скриншот.
Откройте Tools > References там поставьте галочку напротив "Microsoft Scripting Runtime"
 
 
 
#26
14.11.2023 14:53:20
Цитата
Jack Famous написал:
Видел у вас фокусы с копированием памяти, но не видел тестов со штатными аналогами. Не хотите сделать? Мои пробы (не на вашем коде) не показали никакого ускорения… Возможно, кстати, копирование памяти может помочь в обнулении большого целочисленного одномерного массива (вместо ReDim) …
Не понял точно о каких случаях идет речь, функций win-api вообще много разных, при желании можно было бы поразбираться. В частности, есть допустим такая как "FillMemory". Для копирования памяти удобниее всего использовать CopyMemory, но в то же время есть нюанс, что в vba x64 эта фукцияя выполняется чрезвычайно медленно, в отличие от (32 битной среды) нивелируя все преимущетво. Стандартная фунукция Erase для обнуления массива, кстати медленноватая. Вариантов много, конечно если задаться.
 
 
 
#27
14.11.2023 14:55:01
testuser, спасибо
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
 
 
#28
14.11.2023 15:09:28
Ну вы конечно гиганты!
Значения
Названия   строкСреднееОтДоОбщее
$A$17=CallMe(A2:A5)0,020,010,030,09
$A$18=TurboКонсенсус(A2:A5)0,030,020,030,15
$A$19=Консенсус(A2:A5)0,060,050,070,29
Общий итог0,040,010,070,53
И что из этого мне оставлять?

Jack Famous, а нельзя эти строчки как-то объединить, ну, чтобы я не запутался с годами:
Код
Function CallMe(rng As Range) As String
    JF_MainString_Matrix rng, CallMe
End Function

Function JF_MainString_Matrix(rngIn As Range, sOut$) As Boolean
'код функции бла-бла-бла
End Function
 
 
 
#29
14.11.2023 15:13:50
Цитата
dim284:Jack Famous , а нельзя эти строчки как-то объединить, ну, чтобы я не запутался с годами:
Переделал для вызова с листа (не тестил). Название функции можете поменять (везде в коде 4 раза) на любое
Функция работает:
    • со строками не более 100 символов (корректировать в строке ReDim aMatrix(n, 100) — можно 1000 выставить, на скорость не повлияет заметно)
    • с символами до 122 по юникоду (это последняя латинская буква из таблицы). Посмотреть таблицу можно тут (число в html-коде). Цифры(48-57) и обычная пунктуация (32-47, 58-64, 91-96) входят. Последний символ из таблицы регулируется в строке Const symMax& = 122. Можно включить кириллицу и ещё пунктуационных символов (например, символы "{|~}" сейчас не входят), выставив 1105. Это немного повлияет на скорость. Если придумаю, как использовать все символы без ущерба для скорости — обновлю тему.
Изменено: Jack Famous - 14.11.2023 15:27:24
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
 
 
#30
14.11.2023 16:05:36
Спасибо всем! Оставил все три функции, мало ли что. Jack Famous, спасибо за упрощение кода. Символов больше не нужно, в моем случае их либо 20 (если аминокислоты), либо 4 (нуклеотиды) и черточка при выравнивании добавляется. Количество символов сразу поставил 32767, больше точно не получится.
 
 
 
Страницы: 1 2 След.
Наверх