Graphentheoretische Strukturanalyse von Input-Output-Tabellen

Michael Beer, Überstorf - Januar 2000 - Michael.Beer@unifr.ch

Dieses Programm dient zur qualitativen Analyse von Input-Output-Tabellen gemäss graphentheoretischen Überlegungen (mit konstanter Filterschwelle). Aufbau und Bezeichnungen beziehen sich auf die von mir erstellte Seminararbeit am Seminar für Mikroökonomie und Empirische Wirtschaftsforschung der Universität Freiburg. Sie sind angelehnt an [Holub, H.-W. und H. Schnabl, „Input-Output-Rechnung: Input-Output-Tabellen : Einführung“, 3., unveränd. Aufl., München/Wien, 1994].

Anleitung: Nach allfälliger Eingabe von zusätzlichen Input-Output-Tabellen in die Liste daten im Bereich „Eingabedaten“ und der Anpassung der Filterschwellenfunktion ebenda kann das Programm mit dem Menubefehl Kernel - Evaluation - Evaluate Notebook gestartet werden, wonach die Resultate in den einzelnen Sektionen betrachtet werden können.

Die Benennung der Funktionen richtet sich nach den Bezeichnungen in der Literatur, während die in der aktuellen Berechnung verwendeten Variabeln mit dem Präfix akt versehen sind (z. B. steht aktE für die Entfernungsmatrix E).

Initialisierung

<< Statistics`DescriptiveStatistics`

<< Graphics`Arrow`

\(Clear["Global`*"]; 
Off[General::spell1]\)

Boolesche Operatoren

\(matrixmultbool := 
      \((
		mb1 = 
            Table[If[\(#1[\([i]\)]\)[\([j]\)] == 1, True, False], {i, 1, 
                \(Dimensions[#1]\)[\([1]\)]}, {j, 1, 
                \(Dimensions[#1]\)[\([2]\)]}]; 
		
          mb2 = Table[
              If[\(#2[\([i]\)]\)[\([j]\)] == 1, True, False], {i, 1, 
                \(Dimensions[#2]\)[\([1]\)]}, {j, 1, 
                \(Dimensions[#2]\)[\([2]\)]}]; 
		
          mb12\  = \ Inner[And, mb1, mb2, Or]; 
		
          Table[If[\(mb12[\([i]\)]\)[\([j]\)], 1, 0], {i, 1, 
              \(Dimensions[mb12]\)[\([1]\)]}, {j, 1, 
              \(Dimensions[mb12]\)[\([2]\)]}])\)&\)

\(matrixaddbool := 
      \((
		mb1 = 
            Table[If[\(#1[\([i]\)]\)[\([j]\)] == 1, True, False], {i, 1, 
                \(Dimensions[#1]\)[\([1]\)]}, {j, 1, 
                \(Dimensions[#1]\)[\([2]\)]}]; 
		
          mb2 = Table[
              If[\(#2[\([i]\)]\)[\([j]\)] == 1, True, False], {i, 1, 
                \(Dimensions[#2]\)[\([1]\)]}, {j, 1, 
                \(Dimensions[#2]\)[\([2]\)]}]; 
	
          Table[If[Or[\(mb1[\([i]\)]\)[\([j]\)], \(mb2[\([i]\)]\)[\([j]\)]], 
              1, 0], {i, 1, \(Dimensions[mb1]\)[\([1]\)]}, {j, 1, 
              \(Dimensions[mb1]\)[\([2]\)]}])\)&\)

\(matrixpowerbool := 
      Function[{m, n}, 
		
        mb = Table[
            If[\(m[\([i]\)]\)[\([j]\)] == 1, True, False], {i, 1, 
              \(Dimensions[m]\)[\([1]\)]}, {j, 1, 
              \(Dimensions[m]\)[\([2]\)]}]; 
		
        mpb[nit_] := 
          If[nit > 2, Inner[And, mb, mpb[nit - 1], Or], 
            If[nit == 2, Inner[And, mb, mb, Or], mb]]; 
		mbn = mpb[n]; 

        		Table[
          If[\(mbn[\([i]\)]\)[\([j]\)], 1, 0], {i, 1, 
            \(Dimensions[mbn]\)[\([1]\)]}, {j, 1, 
            \(Dimensions[mbn]\)[\([2]\)]}]]\)

\(orlist := 
      Function[list, 
		listb = Map[If[#1 == 1, True, False]&, list]; 

        		orlistb[lb_] := 
          If[Length[lb] > 1, Or[lb[\([1]\)], orlistb[Rest[lb]]], 
            lb[\([1]\)]]; 
	If[orlistb[listb], 1, 0]]\)

Eingabedaten

Hier eine Liste der vorhandenen Input-Output-Tabellen. Neue Einträge können in der Form {"<Beschreibung>", <Matrix>} angefügt werden.

daten={
		{"BRD1970",
			(({{13934, 148, 1067, 61, 5315, 33768, 192, 65, 3849, 964}, {562, 14010, 22435, 2628, 1767, 963, 607, 2843, 2370, 1024}, {4075, 4005, 102283, 56799, 9524, 3004, 24117, 9902, 5509, 8125}, {1259, 3034, 5627, 53411, 2746, 1755, 15330, 8581, 4767, 8543}, {469, 681, 5804, 4978, 32634, 2166, 8292, 5279, 5233, 4246}, {6042, 93, 1586, 243, 615, 20481, 58, 1516, 12398, 2304}, {283, 544, 139, 149, 47, 73, 390, 830, 830, 1095}, {4182, 2143, 21350, 9869, 7293, 6853, 6794, 7409, 7087, 4870}, {1778, 1563, 5647, 8687, 3399, 1917, 6812, 24593, 38808, 21001}, {72, 90, 405, 484, 173, 193, 138, 469, 1908, 4148}}))},
		{"BRD1980",
			(({{13697, 61, 1101, 57, 5410, 41072, 259, 271, 7801, 1650}, {744, 14913, 25101, 3666, 2275, 1506, 935, 3817, 3916, 1744}, {4459, 3745, 1150077, 54934, 9147, 3707, 29365, 12525, 13522, 14240}, {1222, 3295, 6455, 61426, 2301, 1967, 20073, 11151, 12651, 19819}, {403, 512, 5180, 4144, 25068, 2114, 10716, 7438, 9884, 5987}, {9132, 77, 1535, 206, 660, 20305, 50, 1346, 15456, 2552}, {1001, 919, 500, 542, 145, 299, 2583, 629, 1267, 2048}, {5290, 2389, 20594, 11433, 7315, 10822, 2015, 5389, 4237, 1809}, {5088, 3456, 15642, 26976, 8291, 7540, 5060, 21881, 59123, 33633}, {350, 399, 1522, 2211, 639, 1185, 133, 553, 2829, 5009}}))},
	{"Modellbeispiel von Czayka",(({{0, 1, 0, 1, 1, 1, 1, 0, 0, 0, 0}, {1, 0, 1, 1, 0, 0, 0, 0, 0, 0, 0}, {0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0}, {0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0}, {1, 0, 1, 1, 0, 0, 0, 0, 0, 0, 0}, {0, 0, 0, 0, 0, 0, 1, 0, 0, 1, 0}, {0, 0, 0, 0, 0, 0, 0, 1, 1, 0, 0}, {0, 0, 0, 0, 0, 0, 1, 0, 1, 0, 0}, {0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0}, {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1}, {0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0}}))},
	{"Beispiel mit isoliertem Sektor",(({{0, 0, 0, 0}, {0, 0, 1, 0}, {0, 0, 0, 1}, {0, 0, 1, 0}}))}};

w[ XDaten_, filterschwelle_,  ndimension_] := 
      Table[If[(i ≠ j) ∧ 
            (XDaten[[i]][[j]] > filterschwelle), 1, 0], {i, 
          1, ndimension}, {j, 1, ndimension}];

str = 
      (out = "Nummer der zu verwendenden IOT eingeben: "; 
            For[i = 1, i <= Length[daten], i++, 
              out = out<>ToString[i]<>" für "<>
                  ToString[
                    daten[[i
                        ]][[1
                      ]]]; 
              If[i < Length[daten], out = out<>", "]]; out)&[];

\(datensatznummer = Input[str]; 

    If[IntegerQ[datensatznummer] ∧ 
        datensatznummer ≤ Length[daten] ∧ 
        datensatznummer ≥ 1, 
      aktX = \(daten[[datensatznummer
            ]]\)[[2
          ]], Print["Ungültige Eingabe!"]; 
      Abort[]]; \)

fsinput = 
      Input["Bitte Filterschwelle oder -1 für Mittelwert ("<>
          ToString[N[Mean[Flatten[aktX]]]]<>
          "), -2 für Median ("<>
          ToString[N[Median[Flatten[aktX]]]]<>") eingeben:"];

\(If[NumericQ[fsinput], 
	
      If[fsinput ≥ 0, 
		aktFS = fsinput, 
		
        If[fsinput == \(-1\), 
			aktFS = Mean[Flatten[aktX]], 

          			aktFS = Median[Flatten[aktX]]]], 
		
      Print["Ungültige Eingabe!"]; Abort[]]; 
aktFS\)

aktW = w[aktX, aktFS, Min[Dimensions[aktX]]];

MatrixForm[aktW]

Clear[daten, str, fsinput, out, datensatznummer]

Grafiken

ptko[n_] := 
      Table[{Re[Exp[2 Pi i I/n]], Im[Exp[2 Pi i I/n]]}, {i, 1, n}];

pte[n_] := 
      Table[Point[ptko[n][[i]]], {i, 
          1, n}];

\(ptkotxt[n_] := 
      Table[{Re[21/20\ Exp[2\ Pi\ i\ I/n]], Im[21/20\ Exp[2\ Pi\ i\ I/n]]}, {
          i, 1, n}]; 

    texte[tn_, txt_] := 
      Table[Text[txt[[i]], 
          \(ptkotxt[tn]\)[[i]], {
            \(-Sign[\(\(ptkotxt[tn]\)[[i
                    ]]\)[[1
                  ]]]\), 
            \(-Sign[\(\(ptkotxt[tn]\)[[i
                    ]]\)[[2
                  ]]]\)}, 
          TextStyle -> {FontFamily\  -> \ "Times"}], {i, 1, tn}]; \)

\(pfeile := 
      Function[w, 
		gn := Min[Dimensions[w]]; 
		koord = ptko[gn]; 

        		pfeilRec := 
          Function[{iind, jind}, 
				
            If[jind == gn, 
					
              If[iind == gn, 
						{}, 
                If[\(w[[iind
                        ]]\)[[jind
                      ]] == 0, 
                  pfeilRec[iind + 1, 1], 

                  							{
                    Arrow[koord[[iind]], 
                      koord[[jind]], 
                      HeadLength ->  .05, HeadWidth ->  .2], 
                    pfeilRec[iind + 1, 1]}]], 
					
              If[\(w[[iind
                      ]]\)[[jind
                    ]] == 0, 
                pfeilRec[iind, jind + 1], {
                  Arrow[koord[[iind]], 
                    koord[[jind]], 
                    HeadLength ->  .05, HeadWidth ->  .2], 
                  pfeilRec[iind, jind + 1]}]]]; 
		pfeilRec[1, 2]]\)

pf[w_] := Flatten[pfeile[w]];

graph := 
      Function[{w, labels}, anz = Min[Dimensions[w]]; 
        Show[Graphics[{PointSize[ .025], pte[anz]}], Graphics[pf[w]], 
          Graphics[texte[anz, labels]], AspectRatio -> 1, 
          PlotRange -> All]];

gr1 = graph[aktW, Table[i, {i, 1, Min[Dimensions[aktW]]}]];

gr1eps := Display["graph.eps", gr1, "EPS"]

Entfernungsmatrix

n=Min[Dimensions[aktW]];

e:=Function[{w, n},
lieferwege = Table[MatrixPower[w, l], {l, 1, n - 1}];
lieferwege2=Table[If[i == j,  {}, 
                  DeleteCases[
                    Table[If[
                        lieferwege[[l]][[i]][[j]] > 0, l, 
                        0], {l, 1, n - 1}], 0]], {i, 1, n}, {j, 1, n}];
Table[If[lieferwege2[[i]][[j]] == {}, 0, 
                Min[lieferwege2[[i]][[j]]]], {i, 1, n}, {j, 1, n}]
              ]

aktE = e[aktW, n];

MatrixForm[aktE]

Dependenzmatrix

c[ematrix_, ndimension_]:=Table[If[ematrix[[i]][[j]] > 0, 1, 0], {i, 1, 
              ndimension}, {j, 1, ndimension}];

aktC = c[aktE, n];

MatrixForm[aktC]

Strukturmasse I: Durchmesser, Dispersion, Durchschnittsdistanz und Radius

Durchmesser DM

dm[e_] := Max[Flatten[e]];

aktDM = dm[aktE]

Dispersion

Knotendispersionen (Subscript[D, k]^K)

dk[k_, e_, n_] := 
      (∑_(i = 1)^n)
             e[[i
              ]][[k
            ]] + 
        (∑_(j = 1)^n)
             e[[k
              ]][[j
            ]]

aktDk = Table[dk[k, aktE, n], {k, 1, n}]

Gesamtdispersion (D^G)

dg[e_, n_] := 
      (∑_(i = 1)^n)
          (∑_(j = 1)^n)
             e[[i
              ]][[j
            ]]

aktDg = dg[aktE, n]

Durchschnittliche Distanz (D^d)

dd[dg_, c_, n_] := 
      (dg/((∑_(i = 1)^n)
            (∑_(j = 1)^n)
               c[[i
                ]][[j
              ]]))

aktDd = N[dd[aktDg, aktC, n]]

Radius

Input- und Outputradien (Subscript[R, k]^I) und (Subscript[R, k]^O)

\(ri[e_, n_] := 
      Table[Max[
          Flatten[\(Transpose[e]\)[[i
              ]]]], {i, 1, n}]; 

    ro[e_, n_] := 
      Table[Max[Flatten[e[[i]]]], {i, 1, 
          n}]; \)

aktRi = ri[aktE, n]

aktRo = ro[aktE, n]

Durchschnittlicher Input- und Outputradius

\(dri[rik_] := N[Mean[rik]]; 
dro[rok_] := N[Mean[rok]]; \)

aktdRi = dri[aktRi]

aktdRo = dro[aktRo]

Dependenzmatrix H des ungerichteten Graphen

h := 
      (wbar = matrixaddbool[#1, Transpose[#1]]; 
          
lieferwegeungerichtet = 
            Table[matrixpowerbool[wbar, l], {l, 1, #2 - 1}]; 
          
Table[
            If[i == j, 0, 
              orlist[Table[
                  lieferwegeungerichtet[[l]][[i]][[j]], {
                    l, 1, #2 - 1}]]], {i, 1, #2}, {j, 1, #2}])&

aktH = h[aktW, n];

MatrixForm[aktH]

Konnexitätsmatrix

k[c_, h_] := c + Transpose[c] + h;

aktK = k[aktC, aktH];

MatrixForm[aktK]

Kondensation

\(\(\(condensate := 
      Function[kmat, 
		condn := Min[Dimensions[kmat]]; 
		
        a = Table[{i}, {i, 1, condn}]; 
		startind = 1; 
		
        While[startind < Length[a], 
			laufind := startind + 1; 
			
          newset = a[[startind]]; 

          			While[laufind <= Length[a], 
				
            If[\(kmat
                    [[\(a[[startind
                        ]]\)[[1
                      ]]]]\)[[\(a[[laufind
                      ]]\)[[1
                    ]]]] == 3, 

              					
              newset = 
                Union[newset, 
                  a[[laufind]]]; 

              					a = Delete[a, laufind], 
					\(++laufind\)]]; 
          
			a = ReplacePart[a, newset, startind]; 
			
          \(++startind\)]; 
		a]
\)					\)\)

Die folgende Liste enthält die bilateralen Komponenten:

bilcomp = condensate[aktK]

Konnexitätsmatrix mit gruppierten bilateralen Komponenten:

MatrixForm[
      Table[Table[
          aktK[[Flatten[bilcomp][[i]]]][
            [Flatten[bilcomp][[j]]]], {j, 1, n}], {i, 1, n}]]

Die folgende Liste gibt zu jedem Sektor an, in welcher Komponente er sich befindet:

possect = 
      Table[Position[bilcomp, i][[1
            ]][[1
          ]], {i, 1, n}]

Die Anzahl Komponenten ist:

anzcomp = Length[bilcomp]

Wir berechnen nun die Adjazenzmatrix für das Kondensat:

\(\(compW := 
      Function[{bcomp, w}, 
		
        beziehung := 
          Function[{i, j}, 
				b = 0; 
				
            For[iind = 1, 
              iind <= Length[
                  bcomp[[i]]], 
              \(iind++\), 
					
              For[jind = 1, 
                jind <= 
                  Length[bcomp[[j]]], 
                \(jind++\), 
                b += \(w
                      [[\(bcomp[[i
                          ]]\)[[iind
                        ]]]]\)[[\(bcomp[[j
                        ]]\)[[jind
                      ]]]]]]; 
				
            \((b > 0)\)]; 
		
        Table[Table[
            If[i == j, 0, If[beziehung[i, j], 1, 0]], {j, 1, 
              Length[bcomp]}], {i, 1, Length[bcomp]}]]; \)\)

aktcompW := compW[bilcomp, aktW]

TableForm[aktcompW, TableHeadings -> {bilcomp, bilcomp} ]

graph[aktcompW, bilcomp];

Für das Kondensat bestimmen wir nun wiederum Entfernungs-, Dependenz- und Konnexitätsmatrix:

aktcompE = e[aktcompW, anzcomp];

TableForm[aktcompE, TableHeadings -> {bilcomp, bilcomp} ]

aktcompC = c[aktcompE, anzcomp];

TableForm[aktcompC, TableHeadings -> {bilcomp, bilcomp} ]

aktcompH = h[aktcompW, anzcomp];

TableForm[aktcompH, TableHeadings -> {bilcomp, bilcomp} ]

aktcompK = k[aktcompC, aktcompH];

TableForm[aktcompK, TableHeadings -> {bilcomp, bilcomp} ]

Mündungskomponenten und Inputbasis

cct = Transpose[aktcompC] + IdentityMatrix[anzcomp]

kompinput = 
      Table[{bilcomp[[i]], 
          Sort[Flatten[
              DeleteCases[
                Table[If[
                    cct[[i
                          ]][[k
                        ]] == 1, 
                    bilcomp[[k]], {}], {
                    k, 1, anzcomp}], {}]], Less]}, {i, 1, anzcomp}]

\(muendungskomp := 
      Function[ki, 
		kompet = ki; i = 1; 
		
        While[i <= Length[kompet], 
			j = 1; 
			
          While[j <= Length[kompet], 
				
            If[i == j, \(++j\), 
					\ 
              If[Intersection[
                    \(kompet[[j
                        ]]\)[[2
                      ]], 
                    \(kompet[[i
                        ]]\)[[2
                      ]]] == 
                  \(kompet[[i
                      ]]\)[[2
                    ]], 
						
                kompet = Delete[kompet, i]; j = Length[komp] + 1, 

                						\(j++\)]]]; 
			\(i++\)]; 
	kompet]\)

aktMK = muendungskomp[kompinput]

Hier eine Liste aller Inputbasen:

\(inputbasen := 
      Function[{mk}, 
		menge = {}; 
		
        irec[ind_, indy_, kopf_] := 
			
          If[ind == Length[mk], 
				
            menge = Append[menge, 
                Flatten[{kopf, 
                    \(\(mk[[ind
                          ]]\)[[1
                        ]]\)[[indy
                      ]]}]]; 
				
            If[indy < 
                Length[\(mk[[ind
                      ]]\)[[1
                    ]]], irec[ind, indy + 1, kopf]], 

            				If[
              indy < Length[
                  \(mk[[ind
                      ]]\)[[1
                    ]]], 
					
              irec[ind + 1, 
                1, {kopf, 
                  \(\(mk[[ind
                        ]]\)[[1
                      ]]\)[[indy
                    ]]}]; irec[ind, indy + 1, kopf], 

              					
              irec[ind + 1, 
                1, {kopf, 
                  \(\(mk[[ind
                        ]]\)[[1
                      ]]\)[[indy
                    ]]}]]]; 
		irec[1, 1, {}]; 
		
        menge]\)

aktib = inputbasen[aktMK]

Strukturmasse II: Geschwindigkeit und Vollständigkeit

Für die weitere Analyse zu verwendende Input-Basis Nr.:

ibnr = 1;

entfernungen = 
      Table[Min[
          Table[If[
              aktE[[i
                    ]][[aktib
                      [[ibnr
                      ]][[j
                    ]]]] > 0, 
              aktE[[i
                  ]][[aktib
                    [[ibnr
                    ]][[j
                  ]]]], 
              If[i == 
                  aktib[[ibnr
                      ]][[j
                    ]], 0, ∞]], {j, 1, 
              Length[aktib[[ibnr]]]}]], {
          i, 1, n}]

Anteil erreichter Sektoren mit gegebenem Abstand:

relvollst = 
      Prepend[Table[{
            Count[entfernungen, i]/(Length[entfernungen] - 
                Count[entfernungen, 0]), i}, {i, 1, Max[entfernungen]}], {0, 
          0}]

Anteil erreichter Sektoren innerhalb eines gegebenen Abstands (relative Vollständigkeit):

\(\(kumrelvollst := 
      Function[{revo}, 
		resu = {{0, 0}}; 
		summ = 0; 
		
        For[i = 2, i <= Length[relvollst], \(i++\), 
          summ += \(relvollst[[i
                ]]\)[[1
              ]]; 
		
          resu = Append[resu, {summ, i - 1}]]; 
		resu]; \)\)

aktkrelvo = kumrelvollst[relvollst];

ListPlot[aktkrelvo, PlotJoined -> True, AxesLabel -> {(Subscript[v, r]), r}, 
      Ticks -> {Automatic, 
          (Table[i, {i, Floor[#1], Ceiling[#2]}])&}];

Das Zentralitätsmass:

zentmass = 
      N[Max[entfernungen]/(Length[entfernungen] - Count[entfernungen, 0])]