Functions

feature extractor

myPartsOfSpeech[word_]:=
Module[{wd},
wd = WordData[word, "PartsOfSpeech"];
If [Head[wd] == WordData, Return [{"unkown"}]];
wd];

TextClean[text_] := 
Module[{words, tmp},
words = StringSplit[text,Except[WordCharacter]..];
words = Map[ToLowerCase,words];
words = Select[words,Not[MemberQ[WordData[All, "Stopwords"],#]]&];
words = Select[words, If[Length[Intersection[{"Noun", "Verb", "Adverb", "unknown"}, myPartsOfSpeech[#]]] > 0, True, False]&];
Module[{wd},
wd  = WordData[#];
If [wd =={} , {}, wd[[1,1]]]
]&/@ words
];

kw[words_]:=words[[;;UpTo@3]]

httpsCheck[text_]:=Table[If[StringContainsQ[t,"http"],First@StringSplit[t,"http"],t],{t,text}];

httpsCheck[text_]:=If[StringContainsQ[text,"http"],First@StringSplit[text,"http"],text];

which one to preserve? <|”art”->2, “work”->1|> or {art, work}

keep keyword as association

KeyWords[text_]:=Module[{https,cleanText,words},
https=httpsCheck@text;
cleanText=TextClean@https;
words=StringJoin[Riffle[cleanText," "]];
words=WordCounts@words;
words[[;;UpTo@3]]
]

keep keyword as list

KeyWords[text_]:=Module[{https,cleanText,words},
If[Head@text===List,KeyWords/@text,
https=httpsCheck@text;
cleanText=TextClean@https;
words=StringJoin[Riffle[cleanText," "]];
words=WordCounts@words;
Keys[words][[;;UpTo@3]]]
]

KeyWords@t

tweets[[1]]["keywords"]

feature extractor for query

ImageFeatureNN=Module[{a},If[Length@(a=NetTake[NetModel["Wide ResNet-50-2 Trained on ImageNet Competition Data"],{1,22}][Table[RemoveAlphaChannel@ColorConvert[i,"RGB"],{i,Flatten@{#}}]])==1,Flatten@a,a]]&

KeyWords@{"This page describes tags for basic 3D attributes of buildings. For a proposal for advanced 3D tagging see "}

ImageFeatureRGB=Flatten@ImageData@RemoveAlphaChannel@ImageResize[#,10]&

ImageFeatureEdge[img_]:=Flatten[Level[#,{-2}][[All,2]]&/@ImageLevels[#]&/@Flatten[ImagePartition[EdgeDetect[img],Scaled[1/10]]]]

ImageFeatureFourier=Flatten@Fourier[ImageData@#][[1;;15,1;;15]]&

TextFeatureSentiment=Values@Classify["Sentiment",#, "Probabilities"]&

load tweets

ImagePathDictionary[workingfolder_]:=ImagePathDictionary[workingfolder]=Association@Table[Last@FileNameSplit[i]->i,{i,FileNames[{"*.jpg","*.png"},workingfolder,2]}]

ImagePathDictionary[]:=ImagePathDictionary@workingfolder

ToPlainList[tweetswithvec_]:=If[MissingQ[tweetswithvec[[1]]["keywords"]],plainlistbyimagevecs[tweetswithvec],plainlistbytextvecs[tweetswithvec]]

(*assuming each tweet has one vector {vec} and a list of keywords*)
plainlistbytextvecs[tweetswithvec_]:=Table[Append[t,{"image_to_render"->If[Length@t["images"]>0,Last@FileNameSplit@First@t["images"],""],"vector_ref"-> First@t["vectors"]}],{t,tweetswithvec}]

(*assuming each tweet has more than one vector {key->vec,key->vec}*)
plainlistbyimagevecs[tweetswithvec_]:=Module[{dim=Last@Dimensions@Select[Flatten[tweetswithvec[[All,"vectors"]]][[All,2]],!MissingQ@#&],emptyvec,plainlist},
Print["vec dim ",dim];
emptyvec=Table[0,dim];

plainlist=Flatten[Table[
If[Length@t["images"]>0,
Table[Append[t,{"image_to_render"->vec[[1]],"vector_ref"-> vec[[2]],"keywords"->KeyWords[t["text"]]}],{vec,t["vectors"]}],
Append[t,{"image_to_render"->"","vector_ref"-> emptyvec,"keywords"->KeyWords[t["text"]]}]
]
,{t,tweetswithvec}],1];
Select[plainlist,!MissingQ@#["vector_ref"]&]
]

ShowTweet[tweet_]:=Module[{imgdict=ImagePathDictionary[]},Column@{Hyperlink[StringTake[StringReplace[tweet["text"],Whitespace..->" "],UpTo@20]<>" ...","https://twitter.com/anyuser/status/"<>tweet["id"]],DateString@FromUnixTime@tweet["time"],If[Length@tweet["images"]>0,ImageCollage[Import/@Select[imgdict[Last@FileNameSplit@#]&/@tweet["images"],!MissingQ[#]&],"Fill",{400,400},ImagePadding->20,Background->White]]}
]

SOM

IDcreate [somX_,somY_,somD_]:=
Block[{somCoords,somLen,somWeights,distances},
somCoords=Flatten[Table[{i,j},{i,1.,somX},{j,1.,somY}],1];
somLen=somX * somY;
somWeights=RandomReal[1,{somLen, somD}];
somWeights=Normalize@#&/@somWeights;
distances=N[Sqrt[DistanceMatrix[somCoords,DistanceFunction->SquaredEuclideanDistance]]];
<|
"dimensions"-> <|"x"-> somX,"y"-> somY,"dim"-> somD, "len"-> somX*somY|>,
"weights"-> somWeights, 
"coordinates"->somCoords,
"distances"->distances
|>
]

IDimage[som_]:=
Image[Partition[Transpose[Transpose[som["weights"]][[1;;3]]],som["dimensions","y"]]]

IDslices[som_]:=
ArrayPlot[Partition[#, som["dimensions","y"]], ColorFunction->ColorData["GrayTones"]]&/@ Transpose[som["weights"]]

IDtrain[som_,vec_,sel_,ite_]:=
Block[{weights,distances,dim,somLen,sig,inputN,bmus,ns,allNS,nst},
weights = som["weights"];
distances = som["distances"];
dim = som["dimensions"][[1;;2]];
somLen = som["dimensions","len"];

For[u=0,u<=ite,u++,
sig = N[Nest[(1-(u/(ite+1)))*#&,Max[dim]/2,1]];
inputN = RandomSample[vec, sel];
bmus = First/@Nearest[MapIndexed[#1->#2[[1]]&,weights],inputN];
ns = Exp[-(distances[[#]])^2 /(2 sig^2)]&/@ bmus;
allNS = Total@ns;
nst = Transpose@ns;
weights = Total[inputN*nst[[#]]]/allNS[[#]]&/@ Range[1, somLen];Print@u;
];

weights
]

IDask[som_,vec_]:=
First/@Nearest[MapIndexed[#1->#2[[1]]&,som["weights"]],vec]

IDerror[som_,vec_]:=
Block[{bmus},
bmus=IDask[som, vec];
Mean@ParallelTable[EuclideanDistance[vec[[h]],som["weights"][[bmus[[h]]]]],{h,1,vec//Length}]
]

EuclideanDistanceIncomplete[v1_,v2_]:= 
EuclideanDistance@@Transpose[Select[Transpose[{v1,v2}],NumberQ@#[[1]]&]]

IDaskIncomplete[som_,vec_]:=
Flatten@Nearest[MapIndexed[#1->#2[[1]]&,som["weights"]],vec, DistanceFunction->EuclideanDistanceIncomplete]

SOM + data

save som + data with one file:

> kernel: the som weights and dimensions
> bmus: best matching unit
> indexListSorted: indexes of objects for each bmu
> eventListSorted: instances of objects for each bmu

GetSOM[tweets_,id_]:=Module[{vecList=tweets[[All,"vector_ref"]],bmus,indexListSorted,eventListSorted},
bmus= MapIndexed[First@#2->First@IDask[id, {#1}]&, vecList];
indexListSorted=Table[Select[bmus,#[[2]]==cell&][[All,1]],{cell,id["dimensions","len"]}];
eventListSorted=Extract[tweets,Transpose@{indexListSorted}];
<|"kernel"->id,"bmus"->bmus,"indexListSorted"->indexListSorted,"eventListSorted"->eventListSorted |>
]

Compress[1+2]

SOM rendering

render som by different methods

RenderSOM[som_,style_:"ObjectNumberPerCell",OptionsPattern["ColorScheme"->"DarkRainbow"]]:=Switch[style,
"ObjectNumberPerCell",rendercellq[som],
"NearestImage"|"NearestImages",rendersomclosestimg[som],
"Image"|"Images",rendercellimg[som],
"Keyword" |"Keywords",rendercellkeyword[som,OptionValue["ColorScheme"]],
"WordCloud" |"Wordcloud",rendercellwordcloud[som],
"Weights",rendercellWeights[som,OptionValue["ColorScheme"]],
_,Failure["UnidentifiedStyle","The input style "<>ToString@style<>" is not registered"]]

calibrate[word2count_]:=Module[{k,v,min,max},
k=Normal[word2count][[All,1]];
v=Normal[word2count][[All,2]];
{min,max}=MinMax@v;
v=If[min==max,Table[1,Length@v],Rescale[v,{min,max},{0.5,1}]];
Transpose@{k,v}
]

rendercellWeights[som_,colorScheme_]:=Block[{allDims,color,somImg},
allDims =Rescale[Re@Total@Transpose[som["kernel","weights"]]];(*merge by channel / dimension / the total of eachh cell*)
color = ColorData[colorScheme][#]&/@allDims;(*getting the colors from the weights*)
somImg=Image[ArrayReshape[color, {som["kernel","dimensions","x"],som["kernel","dimensions","y"]}],ImageSize->Medium,ColorSpace->"RGB"]
]

rendercellkeyword[som_,colorScheme_]:=Block[{allDims,color},

allDims =Rescale[Re@Total@Transpose[som["kernel","weights"]]];(*merge by channel / dimension / the total of eachh cell*)
color = ColorData[colorScheme][#]&/@allDims;(*getting the colors from the weights*)
Grid[Partition[Item[Table[
Column[
Style[#[[1]],12*#[[2]],Bold,FontFamily->"Helvetica",White]&/@calibrate@Sort[Counts@Flatten[som["eventListSorted"][[i,All,"keywords"]]],Greater][[;;UpTo@4]],Alignment->Center],{i,1,som["kernel","dimensions","len"]}][[#]],Background->color[[#]]]&/@Range@Length@color,som["kernel","dimensions","x"]],Frame->All,FrameStyle->Directive[White],ItemSize->{5,5},Alignment->Center]
]

rendercellwordcloud[som_]:=GraphicsGrid@Partition[Table[
WordCloud[
Sort[Counts@Flatten[som["eventListSorted"][[i,All,"keywords"]]],Greater][[;;UpTo@5]],
Region[Rectangle[]]],
{i,1,som["kernel","dimensions","len"]}],som["kernel","dimensions","x"]]

visualize each cell by the number of elements in it

rendercellq[som_]:=Module[{cellQ=Length/@som["indexListSorted"]},Grid[Partition[Thread[Range[som["kernel","dimensions","len"]]->cellQ],som["kernel","dimensions","x"]],Spacings->{0.5, 2},Frame->All]
]

visualize /image by random element of each cell

$CellRenderSize=100;
$CellPadSize=2;

rendercellimg[som_]:=Module[{imgdict=ImagePathDictionary[],temp,somimgs,whiteimg=Image@Table[1,$CellRenderSize,$CellRenderSize]},
somimgs=Table[
temp=Select[som["eventListSorted"][[i,All,"image_to_render"]],#≠""&];
If[Length@temp==0,"",First@RandomSample[temp,1]],{i,som["kernel","dimensions","len"]}];
somimgs=ImagePad[If[#≠"",ImportCropedImage@imgdict[#],whiteimg],$CellPadSize,White]&/@somimgs;
ImageAssemble[Partition[somimgs,som["kernel","dimensions","x"]]]
]

ImportCropedImage[img_]:=ImageResize[RemoveAlphaChannel@ImageCrop[#,Table[Min@@ImageDimensions@#,2]],{$CellRenderSize,$CellRenderSize}]&@Import[img]

ImportCropedImage[img_,size_]:=ImageResize[RemoveAlphaChannel@ImageCrop[#,Table[Min@@ImageDimensions@#,2]],{size,size}]&@Import[img]

CropeImage=ImageResize[RemoveAlphaChannel@ImageCrop[#,Table[Min@@ImageDimensions@#,2]],{$CellRenderSize,$CellRenderSize}]&

Clear@CropeImage

visualize / image by the best matching element of each cell

rendersomclosestimg[som_]:=
Module[{indexListSorted,showList,lastDist,bmus,dist,i,j,whiteimg=Image@Table[1,$CellRenderSize,$CellRenderSize],imgdict=ImagePathDictionary[]},
indexListSorted=som["indexListSorted"];
showList=Table["",som["kernel","dimensions","len"]];
For[i=1,i≤som["kernel","dimensions","len"],i++,
lastDist=Infinity;
For[j=1,j≤Length@som["eventListSorted"][[i]],j++,
dist=EuclideanDistance[som["kernel","weights"][[i]],som["eventListSorted"][[i,j,"vector_ref"]]];
If[dist<lastDist,lastDist=dist;showList[[i]]=som["eventListSorted"][[i,j,"image_to_render"]];]
]
];

bmus=ImagePad[If[#≠"",ImportCropedImage@imgdict[#],whiteimg],$CellPadSize,White]&/@showList;
ImageAssemble[Partition[bmus,som["kernel","dimensions","x"]]]
]

RenderSOMCellElements[som_,cell_,maxItem_:12]:=ShowTweet/@DeleteDuplicates[som["eventListSorted"][[cell]],#1["id"]==#2["id"]&][[;;UpTo@maxItem]]

SOM query

BMU[som_,vector_]:=If[Depth@vector==2,First@IDask[som["kernel"],{vector}],Table[BMU[som,v],{v,vector}]];

CellElements[som_,cellid_]:=DeleteDuplicates@Flatten@If[Depth@cellid≥2,Table[CellElements[som,c],{c,cellid}],som["eventListSorted"][[cellid]]];

SOMElementsByTime[som_,starttime_,endtime_]:=SOMElementsByTime[som,UnixTime@starttime,UnixTime@endtime]

SOMElementsByTime[som_,starttime_Integer,endtime_Integer]:=Flatten@Table[Select[som["eventListSorted"][[i]],#["time"]≥starttime&&#["time"]≤endtime&],{i,som["kernel","dimensions","len"]}]

SOMElementsByString[som_,string_]:=Flatten@Table[Select[som["eventListSorted"][[i]],StringContainsQ[#["location"],string]&],{i,som["kernel","dimensions","len"]}]

SOMElementsByGeoLocation[som_,{lat_,lon_}]:=Flatten@Table[Select[som["eventListSorted"][[i]],StringContainsQ[#["location"],ToString@lat~~___~~ToString@lon]&],{i,som["kernel","dimensions","len"]}]

MakeQueryToSOM[som_,vector_]:=If[Depth@vector==2,som["eventListSorted"][[First@IDask[som["kernel"],{vector}]]],Table[MakeQueryToSOM[som,v],{v,vector}]]

Clear@RenderQuery

ShowQuery[result_,maxItem_:10]:=If[Length@result>0,
Switch[Head@result[[1]],
Association,ShowTweet/@DeleteDuplicates[result,#1["id"]==#2["id"]&][[;;UpTo@maxItem]],
List,Table[ShowQuery[r,maxItem],{r,result}],
_,Null
]]

RenderQueryElements[selectedEvents_,OptionsPattern[{"Method"->"Image","Space"->"Feature","ImageSize"->2,"Background"->Black}]]:=Module[{imgDic=ImagePathDictionary[],vec=selectedEvents[[All,"vector_ref"]],img,ids=selectedEvents[[All,"id"]],text=selectedEvents[[All,"keywords"]],whiteimg=Image@Table[1,200,200]},
vec=DimensionReduction[vec,2,"ReducedVectors",Method->"TSNE"];
img=(imgDic/@selectedEvents[[All,"image_to_render"]])/.x__Missing->"";
img=ParallelTable[If[i=="",whiteimg,ImageResize[Import[i],200]],{i,img}];

Graphics[{MapThread[Inset[#1,#2,{100,100},OptionValue@"ImageSize"]&,{img,vec}],
MapThread[Text[Style[If[Length@#1==0,"",First@#1],Bold,Italic,White],#2]&,{text,vec}]
},ImageSize->Full,ImagePadding->5,Frame->False, FrameTicks->None,Background->OptionValue@"Background"]
]

SOM overlay

(*highlight som cells based on given input {1->v1,2->v2,....n->vn}*)

highlightSOM[som_,allCells_,colorScheme_]:=Module[{allDimsSOM,colorSOM},
allDimsSOM =Rescale[Re@Total@Transpose[som["kernel","weights"]]];(*merge by channel / dimension / the total of eachh cell*)
colorSOM = ColorConvert[ColorData[colorScheme][#]&/@allDimsSOM,"Hue"];
colorSOM[[All,2]]=allCells;
Grid[Partition[Table[Item[
Column[
Style[#[[1]],12*#[[2]],Bold,FontFamily->"Helvetica",White]&/@calibrate@Sort[Counts@Flatten[som["eventListSorted"][[i,All,"keywords"]]],Greater][[;;UpTo@4]],
Alignment->Center],
Background->colorSOM[[i]]],
{i,1,som["kernel","dimensions","len"]}],som["kernel","dimensions","x"]],Frame->All,FrameStyle->Directive[White],ItemSize->{5,5},Alignment->Center]]

(*highlight som cells based on given input {1->v1,2->v2,....n->vn}*)

highlightSOMImg[som_,allCells_]:=Module[{indexListSorted,showList, i, j, lastDist,dist,bmus,imgdict=ImagePathDictionary[],whiteimg=Image@Table[1,$CellRenderSize,$CellRenderSize]},
indexListSorted=som["indexListSorted"];
showList=Table["",som["kernel","dimensions","len"]];
For[i=1,i≤som["kernel","dimensions","len"],i++,
lastDist=Infinity;
For[j=1,j≤Length@som["eventListSorted"][[i]],j++,
dist=EuclideanDistance[som["kernel","weights"][[i]],som["eventListSorted"][[i,j,"vector_ref"]]];
If[dist<lastDist,lastDist=dist;showList[[i]]=som["eventListSorted"][[i,j,"image_to_render"]];]
]
];
bmus=ImagePad[If[#≠"",ImportCropedImage@imgdict[#],whiteimg],$CellPadSize,White]&/@showList;
ImageAssemble[Partition[Darker[bmus[[#]],allCells[[#]]]&/@Range@Length@bmus,som["kernel","dimensions","x"]]]
]

$LocationDict=<||>

LocationsInSOM[som_]:=Module[{coord=Union@Flatten[Table[Select[ParseGeoCoord/@cell[[All,"location"]],Length@#==2&],{cell,som["eventListSorted"]}],1],name},
name=OSMGetCityNameByCoord/@coord;
$LocationDict=Association@Thread[name->coord];
Column@Normal@$LocationDict
]

HightlightSOMByCellID[som_,id_,OptionsPattern[{"Method"->"Weight","ColorScheme"->"DarkRainbow"}]]:=Module[{idlist=If[Head@id===List,id,{id}],activate=Table[0,som["kernel","dimensions","len"]]},
activate[[idlist]]=Table[0.9,Length@idlist];
If[OptionValue["Method"]==="Image",highlightSOMImg[som,Clip[1-activate,{0,0.9}]],highlightSOM[som,activate,OptionValue["ColorScheme"]]]
]

highlight time is rendered in relative value (num of elements selected / total number of elements) for each cell

HightlightSOMByTime[som_,starttime_,endtime_,OptionsPattern[{"Method"->"Weight","ColorScheme"->"DarkRainbow"}]]:=HightlightSOMByTime[som,UnixTime@starttime,UnixTime@endtime,"Method"->OptionValue["Method"],"ColorScheme"->OptionValue["ColorScheme"]]

HightlightSOMByTime[som_,starttime_Integer,endtime_Integer,OptionsPattern[{"Method"->"Weight","ColorScheme"->"DarkRainbow"}]]:=Module[{activate=Table[N[Length@Select[som["eventListSorted"][[i,All,"time"]],#≥starttime&&#≤endtime&]/(1+Length@som["eventListSorted"][[i]])],{i,som["kernel","dimensions","len"]}],ordering},
ordering=Ordering@activate;
If[Length@ordering>2,activate[[Last@ordering]]=activate[[ordering[[-2]]]]];
activate=N@Rescale@activate;
If[OptionValue["Method"]==="Image",highlightSOMImg[som,Clip[1-activate,{0,0.9}]],highlightSOM[som,activate,OptionValue["ColorScheme"]]]
]

HightlightSOMByString[som_,string_,OptionsPattern[{"Method"->"Weight","ColorScheme"->"DarkRainbow"}]]:=Module[{activate=Table[Length@Select[som["eventListSorted"][[i,All,"location"]],StringContainsQ[#,string]&],{i,som["kernel","dimensions","len"]}],ordering},
ordering=Ordering@activate;
If[Length@ordering>2,activate[[Last@ordering]]=activate[[ordering[[-2]]]]];
activate=N@Rescale@activate;
If[OptionValue["Method"]==="Image",highlightSOMImg[som,Clip[1-activate,{0,0.9}]],highlightSOM[som,activate,OptionValue["ColorScheme"]]]
]

highlight time is rendered in absolute value (num of elements selected) for each cell

HightlightSOMByGeoLocation[som_,{lat_,lon_},OptionsPattern[{"Method"->"Weight","ColorScheme"->"DarkRainbow"}]]:=HightlightSOMByString[som,ToString@lat~~___~~ToString@lon,"Method"->OptionValue["Method"],"ColorScheme"->OptionValue["ColorScheme"]]

HighlightSOMByQueryVectors[som_,newVec_,OptionsPattern[{"Method"->"Weight","ColorScheme"->"DarkRainbow"}]]:=
Block[{overlay,elemCell,ordering,matchCell,cellActive,empty,allCells},
overlay=Counts[First@IDask[som["kernel"],{#}]&/@newVec];
elemCell=Values@overlay;
ordering=Ordering[elemCell];
If[Length@elemCell>2,elemCell[[Last@ordering]]=elemCell[[ordering[[-2]]]]];
matchCell=Keys@overlay;
cellActive=Thread[matchCell->N@Rescale[elemCell,{If[Min@elemCell==Max@elemCell,0,Min@elemCell],Max@elemCell}]];
empty=Thread[Complement[Range[som["kernel","dimensions","len"]],Keys[cellActive]]->0];
allCells=Sort[Join[cellActive,empty]][[All,2]];

If[OptionValue["Method"]==="Image",highlightSOMImg[som,Clip[1-allCells,{0,0.9}]],highlightSOM[som,allCells,OptionValue["ColorScheme"]]]
]

cell selection

Clear@CellSelection

CellSelection[som_,cell1_,radius_]:=
Block[{g,selectedClusters,selectedEvents,sel,lengthSelected},
g=GridGraph[{som["kernel","dimensions","x"],som["kernel","dimensions","y"]},VertexSize->0.6];

selectedClusters=Join[AdjacencyList[g,cell1,radius],{cell1}];
sel=Rotate[HighlightGraph[g,selectedClusters],270Degree];
<|
"g"->g;
"selectedClusters"->selectedClusters,
"selectedGraph"->sel
|>
]

osm boundary

a buffer dictionary, where main cities and all kantons of switzerland has been buffered

$OSMBoundaryBuffer=\[LeftAssociation]"46.2-9.02-state"->GeoPosition[],"46.25-7.35-state"->GeoPosition[],"46.52-6.62-state"->GeoPosition[],"46.86-9.53-state"->GeoPosition[],"46.89-8.64-state"->GeoPosition[],"46.91-8.25-state"->GeoPosition[],"46.95-7.44-state"->GeoPosition[],"46.96-8.35-state"->GeoPosition[],"47.03-8.62-state"->GeoPosition[],"47.05-9.06-state"->GeoPosition[],"47.06-8.3-state"->GeoPosition[],"47.33-9.4-state"->GeoPosition[],"47.37-7.33-state"->GeoPosition[],"47.38-8.54-state"->GeoPosition[],"47.57-7.58-state"->GeoPosition[],"46.21-6.14-state"->GeoPosition[],"46.81-7.14-state"->GeoPosition[],"47.18-8.52-state"->GeoPosition[],"47.71-8.62-state"->GeoPosition[],"47.01-6.92-state"->GeoPosition[],"47.4-9.28-state"->GeoPosition[],"47.44-9.36-state"->GeoPosition[],"47.49-7.73-state"->GeoPosition[],"47.22-7.54-state"->GeoPosition[],"47.4-8.04-state"->GeoPosition[],"47.56-8.89-state"->GeoPosition[],"46.2-9.02-city"->GeoPosition[],"46.25-7.35-city"->GeoPosition[],"46.52-6.62-city"->GeoPosition[],"46.86-9.53-city"->GeoPosition[],"46.89-8.64-city"->GeoPosition[],"46.91-8.25-city"->GeoPosition[],"46.95-7.44-city"->GeoPosition[],"46.96-8.35-city"->GeoPosition[],"47.03-8.62-city"->GeoPosition[],"47.05-9.06-city"->GeoPosition[],"47.06-8.3-city"->GeoPosition[],"47.33-9.4-city"->GeoPosition[],"47.37-7.33-city"->GeoPosition[],"47.38-8.54-city"->GeoPosition[],"47.57-7.58-city"->GeoPosition[],"46.21-6.14-city"->GeoPosition[],"46.81-7.14-city"->GeoPosition[],"47.18-8.52-city"->GeoPosition[],"47.71-8.62-city"->GeoPosition[],"47.01-6.92-city"->GeoPosition[],"47.4-9.28-city"->GeoPosition[],"47.44-9.36-city"->GeoPosition[],"47.49-7.73-city"->GeoPosition[],"47.22-7.54-city"->GeoPosition[],"47.4-8.04-city"->GeoPosition[],"47.56-8.89-city"->GeoPosition[]\[RightAssociation];

osm

$OSMNominatimCoordLevel=<|"continent"->0,"country"->3,"state"->5,"region"->6,"county"->8,"city"->10,"town"->12,"village"->12,"suburb"->14,"street"->16,"building"->18|>
$OSMNominatimCoordLevelNames=Keys@$OSMNominatimCoordLevel

OSMNominatimCoord[{lat_,lon_},level_:$OSMNominatimCoordLevel["city"]]:=URLExecute["https://nominatim.openstreetmap.org/reverse.php?format=json&lat="<>ToString@lat<>"&lon="<>ToString@lon<>"&zoom="<>ToString@level]

OSMGetCityNameByCoord[{lat_,lon_}]:=Module[{result=OSMNominatimCoord[{lat,lon}]},If[FailureQ@result,result,result=Association@result;If[MissingQ[result["display_name"]],Failure["NoCityFound","Cannot find city near this location"],result["display_name"]]]]

OSMGetAdministrativeBoundaryByCoord[{lat_,lon_},level_]:=Module[{key=StringRiffle[ToString/@{lat,lon,level},"-"],buffer,result},
buffer=$OSMBoundaryBuffer[key];
If[!MissingQ@buffer,Return@buffer];

result=OSMNominatimCoord[{lat,lon},$OSMNominatimCoordLevel[level]];
If[FailureQ@result,result,
result=Association@result;
If[MissingQ[result["osm_id"]],
If[MissingQ@result["display_name"],
Failure["NoLocationFound","Cannot find administrative region near this location"],
Print["downloading ",result["display_name"]];
result=OSMGetAdministrativeBoundaryByName@result["display_name"];
$OSMBoundaryBuffer[[key]]=result; (*buffer the results to save time*)
result
],
Print["downloading ",lat,",",lon];
(*obtain by id is more precise than by name*)
result=OSMProcessGeometry@URLExecute["https://lz4.overpass-api.de/api/interpreter?data=[out:json];relation("<>ToString@result["osm_id"]<>");(._;>;);out;"];
(*select the largest one*)
result=Last@Sort[result,Length@#[[1]]&];
$OSMBoundaryBuffer[[key]]=result; (*buffer the results to save time*)
result
]
]
]

OSMGetAdministrativeBoundaryByName[name_]:=Module[{result=URLExecute["https://nominatim.openstreetmap.org/search.php?q="<>StringReplace[name,{","->"%2C"," "->"+"}]<>"&polygon_geojson=1&format=json"]},
If[FailureQ@result,result,
If[Length@result>0,
result=Association/@result;
result=First@Select[result,Association[#["geojson"]]["type"]≠"Point"&];
If[Length@result>0,
result=GeoPosition@Last@SortBy[(Association[result["geojson"]]["coordinates"]/.Shortest[{a_Real,b_Real}]->{b,a}),Length],
Failure["NoLocationFound","No location fould"]
],Failure["NoLocationFound","No location fould"]
]]]

OSMProcessGeometry[result_]:=Module[{json=Association@result,nodes,ways,relations,polys,polysmask},
json=json["elements"];
nodes=Association@Flatten[Cases[json,Shortest[{"type"->"node", "id"->id_,"lat"->lat_, "lon"->lon_,___}]:>{id->{lat,lon}}]];
ways=Association@Flatten[Cases[json,Shortest[{"type"->"way","id"->id_,"nodes"->ns_,___}]:>{id->ns}]];
relations=Cases[json,Shortest[{"type"->"relation","id"->id_,"members"->m_,___}]:>id->Cases[m,Shortest[{"type"->"way","ref"->ref_,___}]:>ref]];
(*join segments to polygons*)
polys=JoinWaySegments/@Table[ways[w],{r,relations},{w,r[[2]]}];
(*replace integer to coordinates*)
polys=polys/.x_Integer:> nodes[x];
(*output polygons*)
Table[GeoPosition@p,{p,polys}]
]

JoinWaySegments[ways_]:=Module[{jways={},rways=ways,i,check},
While[Length@rways>0,
AppendTo[jways,First@rways];(*move the frist way in the pool to the joined list*)
rways=rways[[2;;]];(*remove that way from the pool*)
check=True;
While[check,
check=False;
For[i=1,i≤Length@rways,i++,
If[Last@jways[[-1]]==First@rways[[i]],
jways[[-1]]=Join[jways[[-1]],rways[[i,2;;]]];
rways=Drop[rways,{i}];
check=True;
i--,
If[Last@jways[[-1]]==Last@rways[[i]],
jways[[-1]]=Join[jways[[-1]],Reverse@rways[[i,;;-2]]];
rways=Drop[rways,{i}];
check=True;
i--;
]
]
]

]
];
jways
]

ParseGeoCoord[str_]:=Module[{loc},
loc=StringCases[str,Shortest["near:\""~~lat___~~","~~lon___~~"\""]->{lat,lon}];
If[Length@loc>0,{ToExpression@loc[[1,1]],ToExpression@loc[[1,2]]},loc=ParseKeyword@str;
If[Length@loc>0,If[!MissingQ@(loc=FindGeoLocation[StringRiffle[loc," "]]),loc,{}],{}]
]
]

ParseSince[str_]:=Module[{time=StringCases[str,Shortest["since:"~~y___~~"-"~~m___~~"-"~~d___~~(EndOfString|" ")]->{y,m,d}]},
If[Length@time>0,StringRiffle[time[[1]],"-"],""]
]

ParseUntil[str_]:=Module[{time=StringCases[str,Shortest["until:"~~y___~~"-"~~m___~~"-"~~d___~~(EndOfString|" ")]->{y,m,d}]},
If[Length@time>0,StringRiffle[time[[1]],"-"],""]
]

ParseCityName[str_]:=Module[{loc=GeoNearest["City",ParseGeoCoord@str]},
If[Length@loc>0,First[loc][[2]],{}]
]

ParseKeyword[str_]:=StringDelete[#,PunctuationCharacter]&/@Select[StringSplit[str," "],!StringContainsQ[#,(___~~"-"~~___)|(___~~","~~___)|":"|","|"."]&]

ParseGeoCoord[str_]:=Module[{loc},
loc=StringCases[str,Shortest["near:\""~~lat___~~","~~lon___~~"\""]->{lat,lon}];
If[Length@loc>0,{ToExpression@loc[[1,1]],ToExpression@loc[[1,2]]},loc=ParseKeyword@str;
If[Length@loc>0,If[!MissingQ@(loc=FindGeoLocation[StringRiffle[loc," "]]),loc,{}],{}]
]
]

ParseSince[str_]:=Module[{time=StringCases[str,Shortest["since:"~~y___~~"-"~~m___~~"-"~~d___~~(EndOfString|" ")]->{y,m,d}]},
If[Length@time>0,StringRiffle[time[[1]],"-"],""]
]

ParseUntil[str_]:=Module[{time=StringCases[str,Shortest["until:"~~y___~~"-"~~m___~~"-"~~d___~~(EndOfString|" ")]->{y,m,d}]},
If[Length@time>0,StringRiffle[time[[1]],"-"],""]
]

ParseCityName[str_]:=Module[{loc=GeoNearest["City",ParseGeoCoord@str]},
If[Length@loc>0,First[loc][[2]],{}]
]

ParseKeyword[str_]:=StringDelete[#,PunctuationCharacter]&/@Select[StringSplit[str," "],!StringContainsQ[#,(___~~"-"~~___)|(___~~","~~___)|":"|","|"."]&]

Creating SOM

Column@{Style["some sample data (490MB, 3K images, crawled by keywords, non-geo-taged) ",24],Style[Hyperlink@"https://drive.google.com/open?id=1t0F1t4Qygi-HtbRZoVyrD3Fmrnc8psna",24]}

Column@{Style["swiss main cities sample data (1GB, 26 cities, 8k images, geo-taged) ",24],Style[Hyperlink@"https://drive.google.com/open?id=1F9i0mSq-BOMFodDKVT5Rvcn8vYAzaUlA",24]}

Versions

22.11.2019

Update SOM weight and SOM overlay in both Text and Images.

24.11.2019

bug fix: 
> output format of function KeyWords was wrong (list of associations), change to list of strings
> an issue of some overlay was fixed
updates:
> highlight som by multiple options
> rewrite highlight methods
> show tweets number in space

How SOM works

A Grid of Feature Vectors

size=8;
dim=2;

som=RandomReal[{0,1},{size,size,dim}];
Grid[som,Frame->All]

The Best Matching Unit

we can calculate the Euclidean distance between out query (input vector) and all the SOM cells

query={1,0.3};

euclidist=Table[EuclideanDistance[query,col],{row,som},{col,row}];
Grid[euclidist,Frame->All]
Image[euclidist,ImageSize->Small]

then, we take the one with minimal value as the best matching unit (BMU)

bmu=First@Nearest[Flatten@MapIndexed[#1->#2&,euclidist,{2}],0];
Print["BMU is located at ",bmu]
Grid[Table[If[i==bmu[[1]]&&j==bmu[[2]],Item[som[[i,j]],Background->Gray],som[[i,j]]],{i,size},{j,size}],Frame->All]

Training (One Step Demonstration)

first we compute how much we should update the BMU as well as its neighbors

radius=3;

update=Clip[Table[N@(1-EuclideanDistance[{i,j},bmu]/radius),{i,size},{j,size}],{0,1}];
Grid[update,Frame->All,ItemSize->{5,1}]
Image[update,ImageSize->Small]

and then we update the SOM accordingly

Style[Row[{Subscript["som","new"] ,"=", Subscript["som","old"] + ("target" - Subscript["som","old"] ) * "update"}],FontSize->24]

som=som+(Table[query,size,size]-som)*update;
Grid[Table[Item[som[[i,j]],Background->GrayLevel[1-0.7*update[[i,j]]]],{i,size},{j,size}],Frame->All]

Training (Automatic)

we can rewrite the above code into this function, where there are three inputs: som (a matrix of size x size x dim), data (a matrix of num. x dim) and radius

TrainSOM[som_,data_,radius_]:=Module[{sizerow=Dimensions[som][[1]],sizecol=Dimensions[som][[2]],newsom=som,euclidist,bmu,update},
Table[
euclidist=Table[EuclideanDistance[query,col],{row,som},{col,row}];
bmu=First@Nearest[Flatten@MapIndexed[#1->#2&,euclidist,{2}],0];
update=Clip[Table[N@(1-EuclideanDistance[{i,j},bmu]/radius),{i,sizerow},{j,sizecol}],{0,1}];
newsom=newsom+(Table[query,sizerow,sizecol]-newsom)*update*0.01; (*here 0.01 is the so called learning rate*)
,{query,data}];
newsom
]

we generate a new som and render it in a way that its feature vector represent colors

size=8;
dim=2;

som=RandomReal[{0,1},{size,size,dim}];
Grid[Table[Item[col,Background->Hue[col[[1]],col[[2]],1]],{row,som},{col,row}],Frame->All]

we generate some data points as our dataset, again we render them as colors

SeedRandom[8];
data=Flatten[ Table[ c+#&/@RandomVariate[NormalDistribution[0,0.05],{RandomInteger[{100,200}],dim}], {c,RandomReal[{0.1,0.9},{8,dim}]}],1];
ListPlot[Table[Style[d,Hue[d[[1]],d[[2]],1]],{d,data}],ImageSize->Large,AxesLabel->{"Hue","Saturation"}]

we define a function that plot the som’s feature vectors on top our dataset

ShowSOMWeight[som_]:=
Show[{ListPlot[Table[Style[d,Hue[d[[1]],d[[2]],1]],{d,data}],ImageSize->Medium,AxesLabel->{"Hue","Saturation"}],
ListPlot[Style[Flatten[som,1],Red,PointSize[Large]]],
ListLinePlot[Style[som,Red,Thin]],
ListLinePlot[Style[Transpose@som,Red,Thin]]
},
ImageSize->Medium]

and here is how it loos like

ShowSOMWeight@som

we define some radius of update and use them for training

radius={6,5,4,3,2,1};

newsom=som;
somhistory=Table[newsom=TrainSOM[newsom,data,r];newsom,{r,radius}];
PrependTo[somhistory,som];

this is how the som looks like after training

Grid[Table[Item[col,Background->Hue[col[[1]],col[[2]],1]],{row,newsom},{col,row}],Frame->All]
ShowSOMWeight@newsom

this is what happened during the training

Row[ShowSOMWeight/@somhistory]

Example of SOM Application: expect colors within a color scheme

in this example we see how som can be used to obtain a color scheme and convert colors

we use a faster implementation of som from ludger rather than the one we see from the above code

Color data

1st step, extract 1000 data points (colors) from a given image

colors =RandomChoice[Flatten[ImageData@,1],1000];
Print["Dimensions of the data, ", Dimensions@colors]

Train a SOM

2nd step, create a som, you can play with the som size, but please keep the dimension = 3

som = IDcreate[16,16,3];
Row@IDslices@som
som["weights"]=IDtrain[som, colors, 1000,4];
Row@IDslices@som
Image[Partition["weights"/. som,16], Magnification->6]

Color data of another image

3rd step, we have another image, get all pixel colors from it

img =ImageResize[ RemoveAlphaChannel@,200];
colorAsk=ImageData@img;
Print["Dimensions of the data, ", Dimensions@colorAsk]

Find the best matching unit for each pixel

4th step, find the BMU color using the som

colorAnswer=Table[som["weights"][[First@IDask[som, {#}]]]&/@row,{row,colorAsk}];

Render the pixels using the best matching unit’s values

finally, render the new color as an image again

Image@colorAnswer

Build Self Organizing Maps

Specifying Working Folder

specify from which folder we keep our tweets

workingfolder=SystemDialogInput["Directory"]

Import Data + Train a SOM

Import Tweets with Feature Vectors

With this line you select which tweets (after feature extraction) to import, and then the code will load all the information including, images, text, and date
this may take some time for large dataset

tweets=ToPlainList[Uncompress@Import@SystemDialogInput["FileOpen"]];

Take the vectors out, so we can train a SOM

vecList=tweets[[All,"vector_ref"]];

Train SOM

create a self-organizing map kernel (a grid of vectors)
change x, y value to adjust the size of the grid

x =20
y =20
d= Length@vecList[[1]]
somKernel= IDcreate[y,x,d];

train the self-organizing map
this may cost some minutes

somKernel["weights"]=IDtrain[somKernel, vecList, Min[{5000,Length@vecList}], 8];(*use maximum 5000 vectors to save time*)

make the self-organizing map as an identity (contains both the numerical value of cells, and the instances that used to train this som)

som=GetSOM[tweets,somKernel];

OR Import a Saved SOM

somFile="somFE.m";

som=Import[FileNameJoin[{workingfolder,somFile}]];
som=Uncompress@som;
RenderSOM[som]

Visualize SOM

different ways of rendering

num. of objects

somRenderCount=RenderSOM[som,"ObjectNumberPerCell"]

weights (vectors)

Define color scheme by selecting from this list of color

({{"\"AlpineColors\"", " — ", , "\"LakeColors\"", " — ", }, {"\"ArmyColors\"", " — ", , "\"MintColors\"", " — ", }, {"\"AtlanticColors\"", " — ", , "\"NeonColors\"", " — ", }, {"\"AuroraColors\"", " — ", , "\"PearlColors\"", " — ", }, {"\"AvocadoColors\"", " — ", , "\"PlumColors\"", " — ", }, {"\"BeachColors\"", " — ", , "\"RoseColors\"", " — ", }, {"\"CandyColors\"", " — ", , "\"SolarColors\"", " — ", }, {"\"CMYKColors\"", " — ", , "\"SouthwestColors\"", " — ", }, {"\"DeepSeaColors\"", " — ", , "\"StarryNightColors\"", " — ", }, {"\"FallColors\"", " — ", , "\"SunsetColors\"", " — ", }, {"\"FruitPunchColors\"", " — ", , "\"ThermometerColors\"", " — ", }, {"\"IslandColors\"", " — ", , "\"WatermelonColors\"", " — ", }, {   ,  ,  ,  ,  ,  }, {"\"BrassTones\"", " — ", , "\"GreenPinkTones\"", " — ", }, {"\"BrownCyanTones\"", " — ", , "\"PigeonTones\"", " — ", }, {"\"CherryTones\"", " — ", , "\"RedBlueTones\"", " — ", }, {"\"CoffeeTones\"", " — ", , "\"RustTones\"", " — ", }, {"\"FuchsiaTones\"", " — ", , "\"SiennaTones\"", " — ", }, {"\"GrayTones\"", " — ", , "\"ValentineTones\"", " — ", }, {"\"GrayYellowTones\"", " — ", , , , }, {   ,  ,  ,  ,  ,  }, {"\"DarkTerrain\"", " — ", , "\"LightTerrain\"", " — ", }, {"\"GreenBrownTerrain\"", " — ", , "\"SandyTerrain\"", " — ", }, {   ,  ,  ,  ,  ,  }, {"\"BrightBands\"", " — ", , "\"DarkBands\"", " — ", }, {   ,  ,  ,  ,  ,  }, {"\"Aquamarine\"", " — ", , "\"Pastel\"", " — ", }, {"\"BlueGreenYellow\"", " — ", , "\"Rainbow\"", " — ", }, {"\"DarkRainbow\"", " — ", , "\"TemperatureMap\"", " — ", }, {"\"LightTemperatureMap\"", " — ", , , , }})//Grid

colorScheme="DarkRainbow";
somRenderWeights=RenderSOM[som,"Weights","ColorScheme"->colorScheme]

keyword

colorScheme="DarkRainbow";
somRenderKeywords=RenderSOM[som,"Keywords","ColorScheme"->colorScheme]

wordcloud (another way for keyword)

somRenderWordcloud=RenderSOM[som,"WordCloud"]

random image

somRenderImg=RenderSOM[som,"Image"]

nearest image

somRenderNearestImg=RenderSOM[som,"NearestImage"]

put three renderings together

ImageCollage[ImageResize[#,{500,500}]&/@{Rasterize@somRenderCount,Rasterize@somRenderKeywords ,somRenderNearestImg},Method->"Rows",ImagePadding->10,Background->White]

show elements of specific cell

cellID=1;
HightlightSOMByCellID[som,cellID]

RenderSOMCellElements[som,cellID,5]

Save SOM as File

somFile="somFE.m";
Export[FileNameJoin[{workingfolder,somFile}],Compress@som]

Working With SOM

Overlay two Datasets (for comparison)

tweetsNew=ToPlainList@Uncompress@Import@SystemDialogInput["FileOpen"];
newVecList=tweetsNew[[All,"vector_ref"]];

somRenderOverlay=HighlightSOMByQueryVectors[som,newVecList];
ImageCollage[{Rasterize@somRenderOverlay,Rasterize@somRenderKeywords},Method->"Rows",ImagePadding->10,Background->White]

somRenderOverlayImages=HighlightSOMByQueryVectors[som,newVecList,"Method"->"Image"];
ImageCollage[{Rasterize@somRenderOverlayImages,Rasterize@somRenderNearestImg},Method->"Rows",ImagePadding->10,Background->White]

Highlight SOM by Location/Time/Keywords

by location

get the location names and coordinates within the data

note that this ONLY works for data crawled based on cities (meaning that your crawling parameters include something like this:  LinguisticAssistant)

LocationsInSOM@som

choose your city by COPY PASTE the FULL NAME above, and you should get the coordinates

cityName="Zürich, Bezirk Zürich, Zürich, Schweiz/Suisse/Svizzera/Svizra"
cityCoord=$LocationDict[cityName]

see what are the main activities of this city

HightlightSOMByGeoLocation[som,cityCoord,"Method"->"Image"]

render the corresponding elements

RenderQueryElements[RandomSample[Select[SOMElementsByGeoLocation[som,cityCoord],#["image_to_render"]≠""&],UpTo@1000],"ImageSize"->1.5]

by time

or check our data by specific time period

starttime="2015-01-01";
endtime="2017-01-01";

HightlightSOMByTime[som,starttime,endtime,"Method"->"Image"]

render the corresponding elements

RenderQueryElements[RandomSample[Select[SOMElementsByTime[som,starttime,endtime],#["image_to_render"]≠""&],UpTo@1000],"ImageSize"->1.5]

by keyword (the one which was used to crawl the data)

or by keyword

key = "beij"
HightlightSOMByString[som,key,"Method"->"Image"]

render the corresponding elements

RenderQueryElements[RandomSample[Select[SOMElementsByString[som,key],#["image_to_render"]≠""&],UpTo@1000],"ImageSize"->1.5]

Select Cells on the SOM

select specific cells

select cells by specifying indexes and radius

selected={22};
radius=2;

cells=CellSelection[som,#,radius]&/@selected;
Row[cells[[All,"selectedGraph"]],Spacer[10]]

highlight select cells on SOM

HightlightSOMByCellID[som,Flatten@cells[[All,"selectedClusters"]],"Method"->"Image"]

objects within the selected cells

selectedEvents=CellElements[som,Flatten@cells[[All,"selectedClusters"]]];
Print[Length@selectedEvents," tweets selected"];
ShowQuery[selectedEvents,5]

render the objects in feature space

RenderQueryElements[selectedEvents,"ImageSize"->1.3]

render the objects in geo space

renderTweetsNumberInSpace[selectedEvents,"RegionLevel"->"state","GeoBackground"->White]

Query to SOM

Query By Image

copy paste your image here

query=CropeImage@

If you encoded your images by RGB

vectorQ=ImageFeatureRGB@query;

If you encoded your images by Edge

vectorQ=ImageFeatureEdge@query;

If you encoded your images by NeuralNetwork Feature Extraction

vectorQ=ImageFeatureNN@query;

If you encoded your images by Fourier

vectorQ=ImageFeatureFourier@query;

Query By Text

query={"There is a saying that lightning never strikes the same place twice"}

If you encoded your text by Sentiment Analysis

vectorQ=TextFeatureSentiment@query

If you encoded your images by Word2Vec

extractor=Import[workingfolder<>"extractorText.m"];
vectorQ=Mean/@extractor[query]

Obtain Query Results

best matching unit

the best matching unit of our query

bmu=BMU[som,vectorQ]

show the best matching unit on the SOM

HightlightSOMByCellID[som,bmu,"Method"->"Image"]

show the elements contained in this BMU

obj=CellElements[som,bmu];
ShowQuery[obj,5]

around best matching unit

select other cells around BMU

radius=2;

cells=CellSelection[som,#,radius]&/@{bmu};
Row[cells[[All,"selectedGraph"]],Spacer[10]]

check the selected cells on the SOM

HightlightSOMByCellID[som,Flatten@cells[[All,"selectedClusters"]],"Method"->"Image"]

show the elements in these cells

selectedEvents=CellElements[som,Flatten@cells[[All,"selectedClusters"]]];
Print[Length@selectedEvents," tweets selected"];
ShowQuery[selectedEvents,5]

Render Query Results in Feature Space

render these elements in a nice graphic

RenderQueryElements[selectedEvents,"ImageSize"->1.3]

Render Query Results in Geo Space

renderTweetsNumberInSpace[selectedEvents,"RegionLevel"->"state","GeoBackground"->White]