From 5fc290e832421f50482e82e84f2b707c03790375 Mon Sep 17 00:00:00 2001 From: spegg Date: Wed, 30 Mar 2022 17:51:19 +0100 Subject: [PATCH] Implement changes as requested by JNCC --- MBA_MESO_Nodes.xlsx | Bin 0 -> 22647 bytes Parses.R | 28 +++++---- app.R | 142 +++++++++++++++++++++++++++++++++----------- extract.R | 111 ++++++++++++++++++++++++++++++++++ reWeight.R | 132 ++++++++++++++++++++++++++++++++++++++++ 5 files changed, 369 insertions(+), 44 deletions(-) create mode 100644 MBA_MESO_Nodes.xlsx create mode 100644 extract.R create mode 100644 reWeight.R diff --git a/MBA_MESO_Nodes.xlsx b/MBA_MESO_Nodes.xlsx new file mode 100644 index 0000000000000000000000000000000000000000..5567bc886f27a092e74164c0a3f0d0451afe130d GIT binary patch literal 22647 zcma&Mbx>PT*EiZ?#T|;fy9S5i4#i!A1$UR??(W5lyA^l$;_mLQz3KCOGvE8qeecaA zXLgdke9cZkwlLIAG~98ImAn3?`vD-(JY`dAP{F1;e? z9y!;)!R8gW$w{@5au9V>*y1;a7xV|-JcwbSBSzQt#W?u-eHa&Q$k{S%uu#eBhpTCY zLv&C9eMcnY%bXpkk6x(>_86?m6$x1%GO zhQNDlnEJGiZC)lJ<07(1$)lx`9$XA#&o#%8z9)?xr=?;1Zar|cH@<_JXh#oXF?aTo zC-;$(yU4{NWH*qB)XsSuJHYrZ`vo>QgCpYt?1V{(PoKX3zq$zpyu;m^+0D+;%Gl1% zipkx^I$A~EZj}YG<5I(2q()~awn0B*fVQqs0>PQsqU}L*7+cROo>DXc!>#Y*)q-bI z+d7ocIy_%Yuv3z0a#hBiZ#slNJY| zR>L!sw(LYw10(asVnDIL9Ay*D<1D65gQnBbYVI+=$HT;9{wVZG$V72fvI9yHEPIW_?< z5zQFN-;F*YFwTF-J`g%aVkwb^4gCtfV&KNDYKPBb*y!hQUm{#{TFMmqm~=*CPCgJy zYEWG}(1wdgEzcAMKv{ZxFi+V?{vn(gw_g&pANeClN;7jC`MzO8%w10jkE3W#-M376 zRWeIuf}JDYU(eBY940di`Y{Dx740Ieiy4u8_UYCI8+)(o*DwfBk>ecnJ5_(lXkY@X z?@yHy!;9);BiSehc}jyz48^NkC(B$_V^M+LoOZVl=OeV@JU+6gNqw!NJNB6{7oyS~+Xo02Na z#{*od)X3x8YRFYYuccY#>P4`TKY&PIydZm(#RT92NY0*qEa>B(F7zS72ETS4 ze7lkp-F&u%4O_IxiOap*rO}_-u^_1IJ?2JaRv02Kp)T3IBa>IUxi|Ak`RMhxS2}#E z^m-e#%(}p*vCXZeT@BK0;0a6a+uLpYxcvDn%FgTu`7b3&8GgR0gVT`~>VHc~r2nR* zle34lsnfrNJlENbUExOc?dl>MedYB3mXh_OENI`Exuk4ehFZ;sCEWj43?WZ(@W;LR z5JixooxkZ-&cr^xH{?71?~1+p~GUkxi=U{VK!_e27|CnNYX zLihQ?-~?hSJ_R@O_-UH+=dn!L9~WCZW-d6vFI2id+6QL+q`;;*Fv=deUiUHQz_u+$ z5+~^l{+lsHEs+_td-3blc!r8h1#_k;f?WbX_TrM7P`rT!^Lmo7lB{CHWIoS4%Jnif zKuK}n-}-_}IxT;*_d9+i_fCC7o449^398>W^6!~qoK9VPw}`wvG8jeOSUaM|se z*sZ8*7LIi0{`h#gpQKUoNx4Y?h_E|vZK!h1p{JZW!&36&*nP1<*;QL3xY$X}Vr4Ois)Yroq|+xg z^La&ZgU^GwE8|?W8q$;OVX>*yk937YQDmwo1JMO-c7!xA#2_jF|2Evf z#b0oo!zZ7kXK0^8KSj0yGh4oY7Wb7Pv`er9Z5G)h-Au}BlJ=a@X@PS!nwm1hPKqz5 zflqYhy6_$mWVZ*}!dv`IXnp`abo-&;y;_m|B6@98?|O3C-#oG6A$e5p$G&I%A+1`D zvQ(N~UYPQ07;ous#0j5jfz59@RN0z##|I>lgyNspn3&e07^k=3%o}GAD~m8qpjZ&2(hI8=ByrBz;PR zw>&zlfvO8KoSds7jm3kHdK!oFq4Js*JF1kHp-z>THa;QzIbVJY`Y?z(yOm9eDeacb zT3h{nSSmfaQ+30m@j!skBPdlNpWdHra;+{!<0)#oZf8*)Lc4Y$*Q|zv$d=g4=auv^ z=!;?QJo%W3MxR1}Xp~s`h31~4KrT_BUm!}ta>SuutH2Zeyh?lMVy*)#^hW%z7*?Jh zlFot)p}f%lRt(AiZ+~{OFg0~{V*W3v`Og>Df7S6n@FqHT48E5IRs7LcJgr0eR75Pp zm0YA*S%`#Uj$?^mYUlKFLZWu7cYnOYDP+zWg)b3*(4>9$`y4zh?{Tt2MxO_FmD_Y< z`9VfLf#Jb>`>u0BO$w z(uXn_Hh##DzK2~43ZnLQZRh79gyQ^`udxA`O2C6}$6k+cR@yb)5o9{tP0arc@118& z{RK7)@ALm=INpB^|F5*p2jD*5?T_d{Ys)#y{gBXtoGm4(V8@ejW+rh1cU?^u=7bxvlD0glO?eluU(h0#3m}z zK>T}0^U}A;@;Se3cVeh-_&^ux~jz`mF!wRIZ3WT3Md z6F#LX>MTLnZePKsbc@weSDLGQI5qZoU#=B>hlY#Mo?Nt2D4v$9#B5W0@CM4w2B2wy z(qUEDBg61uc7*MRCq{MGld&`Gg7j@s!>q^s0Br$<_xpZY1C;L}pJdyK4sxwVa+Ml} zSWW%~U0Gp}wN8Po7Eb=l0MIE->g%0qsy5yq?Kp0v2jNB--(X3+MBx*`t>6R;W(>wM zz&Sy1qL^2Xvn_lVI_$M-;ODMihLZlH`B&+(MLtIa6YJ|E&`PcH@W*q9d?1TAC zjz2mfF{-%3V(pRjj%&tARwj~~;OZ8lDfmhd0KLs+e?}2XEZgEjTqPk{^fO7Kawb4B z{GV^!!&nJ1w8oQl8PXYWej3mDC8BEZO#aAB<5_L&&kSvV6d3c?;wh(RCc#1r)>*k! z2XIt>G=+Z9ojyQgL?J@~wi+nnb2)#)BeC*kUoZGpmZkQc@MQB7X8u<^Z z{jx7nB_|0)^^ir(6NNb9m4eE^<-ME6lEKUdq+!6%pOl{At;9@G9zaQ$j`*pKhVcy} zg#OrWwlU{ml&h%eoSzIxv>o-3Y)g_!u4}|%?Xs`?snmJEpkr}Gg^-V(ZN5`Gd>!CA zv`^q1`#Vn&d1RVV!Qg}W*)oiu(B8w{LU`;s2oMb+^znz8AuJqIk zLAua+>`Sp|YOi?>n$U*G+>NwV3aW}hSQ`tK)B zWivS1rhA3VWocl;V`g89P|C2I;l$f*hgWM-ejW~JiVUVeHC7xlqP&)3suE?)xfznR z2SDVDgd(C>{Z2q^*Ncx__vZ21SqRy3DmO*(V(bz?Thz11W3PAAk`Uc|)LYg5>O`X} zCyLwL<}b&s?J4N|=%n=x2Od_(!ZG>971i?Qc9)1{vfOiG5`lHXsP|i?HeDP%CSCxb z*6_p#nM_2qGZw{i0k@U5U?zFc(ZXdX`K*dk6HQ&NH?wzNtqb(^z&{>7BdkCDh%#%_+-ki+M7^2PMt2E~@$;@4OGRSV6 z{*XrIwp$q_c$MezH~OSgxwy;JoMQTq_8(e1J`MD~K{08ucngF0UzW!mX?Vl7L5M%; zjhmrZJ+I{mBFP;%cw-D=K_cE2(SMn-;Q+LP71(`P@W)uXMJK_K>cM)7YNC{HV>8>4 z!xI>l9FXwB^?sZL^TS&GJ~!66P5e^s*#LgwcX;pdiCl+?K{kzOnPqoyCSfTJ;2k=CrQV%59U2=P!C4Bl zj$16=_5B+dXygZzmiqnmD|d09O0Pjd{xH>ew#~U5=QqRboF15nA{I}7yv@3s!Kv%% zmabvN9Rdgn)cjLz3tE=iqypl&fsQ?7Py`yc0cmrwgTS9{Z`b@pw<|&lxh5D~&P0uhVu%{cwQ7 zbTPyOp3JXgEdTAu!#`WteIZNoveVz}K5a`v6F8Lx5=S=l0%sl;J~ugB>3VOh&?ec{ z5aDPpw3?u9@}gQiL#aE{uG!)clKe=+LK^t9tZf|;wlJ4c^{GkU=hQxOqS#W9ns2^g zILJu$>#BEsvnK&0@gHtP0bii?XNXWasQp$n3awWl0m#Zw2MF}%tBziWoosM&Ld=xt zZ|8{pqBF(v1sMqiCVJoE-ZZDYCWNJ-_>+~G(`0@p8zG(0)2D)M#RiFlW)-PgrLiz% zV{t{YF518%mE3ek5dQkS{Sf=zo?eIDE7rrV`iPaZL2rkOsoR3e92@JV_B3UFKTbn) z+?ZT)fnN5W+}_R_LSsOgr^lq2wPy9oFvp9K)@>b}`M0KvY^PY=RS|s3ows52(fR&Y zq*?jK+_{o(E!@pYeg{AtVuZQ8d`D!CKsk(h)BMN`4rTme%ts zlI6`a=?y^s(fxMNO`~ZEFg}0!^}#D2_vL9Rx&(${t(vNxThOF`;HZnI){fp*X_q*r zY@VBZq+9j+fEpuk$5ap~BRhO-mIP=1o|dk>X>>1r_R}2k?UDSh`59v!++@Q&tT}|| zdFoM@!>fP1TDQ%UjZUXJ_I$rjx!0!bG+SLA4tlg8!pN0mMc3NF#OcKgXX{{x#MoJX z+f6m|+F1i#+MIHF=fY>92VkhKGz3xqfS;sqXIMejMA;=$6txws=*2g;{f$+g#n@FB zh!ulJ&_p;r=as)ItdK4k!i#=X&elL(?xzgrAb#C&xi%h&zAPV)%w zENi1$`Zl?W)K|B7zd;th`OOv=rM17yOKa9EL=~n85~0v+I`uT9KMh({)c+|jc?}b@ z{3CN}iexWISB+Bh?`S$Q!GOD}vW%$=^`+c6)35c#EO)c(&l#3XjfhUN zZTBtiHqplx!DWe?JZu|x*inu&p6yS<@U_dVs~EBMa1M}KXy3Vgm|cCoDAa}L@lvid zcxdyh$qeDhON%MVd#xwz{RGU~AXm8jCc1-X@39T-Nn6|DZstVaT(U-N&wY2QKQ#xr zuHU}d#a6K!=td+T6&8qd+;a{{>>T?Ob6sZ@x>4>a*(gp~NbtXSlO4{*33`$2AQm(0 zy1R_2>m?AzGN#s1J$y1st%x!z$m=;a|7q~^0b_x<+7JRr9ok+`aOD2Q=+U&U-IzMV z7nZm6;m-Gr55}hB?oa=tKsHB+g9MZgX9Q080A8Yr;+Oa@2}jaNWWSd>2e$>Jmd1cS zo^5$b(Usxq-VL7RDL0EJ+vd_UipJpz+BWwmPXV{89&Ni_zU_dQWyqQM$L%|ze_**Z zL{aG!{?n&ovH$HDf%9LmY~pC-_75jB|DVNwPEOfz6UYH9s6m&4(93O@0yv^it*E)* zhz&)*T8K2uH^X;!$j7x^bEl7|rkAeFPcBCW;0$qQ-9WJIY=HWJNU^Wy?!j_ob%V>S z^H)^ zV`7+X6aLI7e}8Imv>*Ce?uPW-{b~IGh3~?^aRB8EhE3YPsg(Ly+*d0w6k|&2HH8A{%4-6JO&+a-Hod-hofWb|dw#nyax>>|1KRPdbCInC0NRr=l48&?{R z(JF)Bcz+1bo#Ypm{j3a;T&J5(2@KDQByd6w+4N}aTGH<7yU(a^cH6FWhV=bAWQgd)WDH0U&&zZ{;IH^uF(ts>WZx3OEd zX{uzAP@S)T%P6CQ<~~k#4fSu2p4!jAgbP;bb^ij%BTA;@JEUKLf~q7+$JSHiPk`1J zGD{I_C|*`~UdR4y0d0nh@<%Z-lOS^rjy&beGPec#yW&Xcm&GQIPL%+&WG zFwWLtSNd8X^5Py7+7}iN@G4)54S%HqFRL!r5uceL#y~Uk(eh~3V%R-YDS^iNoo?7!V zqe@9s0OUuh8!~9Hi58fIk;SR9G9BW2W(o{6Td)xo)>p#dKkI_nRk=$pS(+L?30voL zND+@DqxC-*r32-U0>(cZpoDUz(H(#Ly#$TIp+HPRJvJ*Ii{GW^)IlKr=%WA4G|WQJ zQ6>vz7j>YL7qaLawTj|ZNpDRx#oaU+h){JtzX`>7DD+7;XtLM0ZAV44tq|UQB9gdy z8!?}j^&%ZM_s6CvHTQ9AE?~B}-^vu5ScWm-qPBTjHOC2FZl>req2CfRXc?kAoUJq` zoJ5ysTc??^=Rv+&?(d8TWz9r?`2bClW6v@dmUq1uLEpw-DMFXmQ0i?F$Qo$YZvE_Q zF1btdt?5@O!tpp4snw3Gzod8tOjT3actw?67)V*jYZH9GfalTO+#5bek79N{uA!*5 zJTPaf06p!J{^h5Y11|5los+*DAOD%|Pz~Nr`~U}U66XI$!}>Sz`ac7||2yjI$kub( zmB=W%eAHk$F*bfQE(?q8myAA#^Bcw%Q)??Y--ub_lL^vAlr0P?EYtnCM^F|+_nwm8 zat;b_J)#wrd^UrS1lRbTJ&nKbLvy=(DjmyAi{;guVs<5VRQD&o9hz0XuP+lqe(%>p zkz9%Aww>DJ#Ea!Gr(6an=b3*$4*Y!XJvyF!UTdq|5{v!kA5OW5-P#TxFE?y1g%%WV z&sXoAIxKx}YBu;M+$Q{NeZ87}HvZfWY^UZBZ4S(V9xgzgx*Z-i+wT$};QLigd$phD zW*7f_`MMQ(=8Hq8)$gwN7VnLw%Jq?+|0bD_haYl(8b)RhkVQxFYOJxh1L7M zi}UxF<0Vc4)8{IF{KL79+1irlgU8gvzt(uZwlHqZ-nti^1TRkqnbpYAe|^|JGzBkC zCPMG?TbWR9hium0&OAPJ-eo&p4{x^*+YA={?2sFTd>=f8Rhb)6Aql684| z{MHeAfx*7-d)s$tz7$ch?EuC4S$e+RXU=~F2?FG+avv!>tBHvpA${0eH?7Kx-x++^ zpPf2YiSDvT32z^%x)^aCTpHuJ0whKA@SmzE(UWG#1?q43?^L)zZ`hqp* z6NP*|Y?;uOg6EO=yIJwPPjd$7!l9UI8kpQ#JYP`njF z*0=?=^1l5&zZlyP@#1R-Bo@Bb-!3jh#@-t%Gc#@eeye6qCy=Eo+@m}x8uFwqO~tk= znK3Y!C6wj$Ro_L3V&h90_Z~SiA$SBt|9wdqs5O~Xuzmsj{-HMp9GOjxQluGw$uz-uOndftyG{o=Jfw*UPa$ z5pIaS5cAC5Ap;|yKp=k;`||AIYj7#V()E{nQ!|$$Kv6TaLUE~kJiEXc?=(^DN*Y2? zT0~G<@-Ry`}6TPT^U`(C>`jzWwOEvno@YAv-uY9dwZv7m0f zv_M+A6^BWX5JIpc;TncP0G3UvU=ItT1~gW!{S;lBA?<3nCd%L&G4X9qx0|6>xPrq^ zyB|@S%Z48?yTZb6zYoXo-sz@h+Do)H$u$X3OdEWm!0;AX36DOY!@rY0@NsMw&^E1I zyU+)?4brA>VFEZ#lcKl>#*66y-ls`&_A)REBO(eTlCCmL+`*s<6~`W0u;y81<=)e@ z&oi`tGyKY^?}?{Q2bu5pK6btDb!^%b5cG`#>-9&%HO}}`vOk?B>t4wq>yL=)(@H$Z zkh+7pXu$W-gSkusBZaFmC9B_7)+AFR_b(70rAeQHkj7tv5E+_oH39CYi6U3hp9N_} z1Zlypqy3NTWd6CXe-bz*oSXC^dTq(&r(JbmLZ<^yWmHf{MOq+prkWDHmQjc)ryL+X z8Yle#Yo^-{z_Jz*U!bo1wMbJ@)IVt+9j0ZfSfX!EH+BDBx1j*IpL>~mn;~m0HT=rU z`^m|~IXruAR>hETF2a-1>0~Z^Mn13@H+w`P0+a?The2CR%1G(zXeIWCL&+**fA_-P z$>VQ}5aa?!yfGetmjww|&$y)d4)X_yY=8qTg9<*w%vuVcHYp{dn*+YY6il1*kCrvf z?4~xy@5NZJU`v~q-yR89AHo2VroRd6z6~b*9K^7dQCn(LXsAOa1AmIw%al0#JES3L zB|QoaZBbQe%(l9V0dTr+%=aAoJa_9Se*rL9@T)p3uXKrpa5!%L^az_DksZlVcR@#2T(p~NCA1-__s%TtNL?w?xl51pHbV``RVj># zkZ(yGRn7VgWPC32%Qi#1jby9nNa*Q<+%wx$s22bkML_=i1a zhwpZWC$Q6<=W%UmiCeja6(jEumREc#K81k)24>j-tMTgTb>a=#Rui7381hRXTz&-7 zTF-6tH{e&DKvK?_fF*9cOngarZZon5c+wIJtl5OXV79=kmI!UnxAnT`@sHAt&Rl{n z+nOe&B~}4ALwsS?+QcnoEBxNrN(*e#Z!rN-Jb3t|lJKHn4oII%E%0X(>aEQ3g=2KZ z8KpiB4?cDs?>l|<1;-84oviSnDdto@6{Cq^@j)XChNGpOIa=Wrj#x8P!Seqaq#BP8 zNK1#c>9=QC3TxPtu__QA2Xit1u&rM^CprZK5C6mD-t^G+H2>EEfAH+Ba1J>1u3KHL%9oi{zdqdt^8D`C+lVuP<8Q`+7aNdu03kh8X85!we2*F9emv&_OHWK<{p#%cSTT>k zJ+pERr@&`JdT5<`jJTl%btoO383qY!!Y{Qh{151Rnt2OyK`BbVIIU=#iBETpED1{< zfbZp2!wk~fi+2n^>@a;NCPi$87Kefi{t^26;2}JjS!)y0H)MoQbHP`FMY2HR70=g_ zH{%)OK`Z}@r4k7zA2g4g_b|FCeZ~N6sUq<6TvT)>5Soh}EkmMbqN0euxfpkF!od}A zy(~CEe14Lv=|AcGWQYUJTfcqyu-~5c?QpF#_ba)x8IV>)C99Uzxx&zbita2kL)FA! zp^(g7AF0|XMiIxe!(exE0e>*)+t<>2)aebY70I?cYV{QQp;1rMvmP6QJ#fI_5gt?~dm4~-GlG9r6zQM`sy(R0WcRIh_Lgd#6ZGAZs zCnfDunmBNyFKvve%i&SS<`{xa-z70o7z`N?he%I{&2qxL=L>CAT|rq>HPL=yB|U55 zm}<;L-)dNN|0M(ab?~c8a`N!flMNe^{;A->=}q&ofp4Z1=Fym#sU_R zgHFxg&3J$>%t^8D^JNqf8mXxmDw;NRd_~`h{I;uzn!S(_jVnAC=2p&s^fwp`8xP>`td=uWo0#$nrgTV)vQV2$3`54B9+9lzO=K_7EEA z_4Ru`A-agt43?BqB8j;C3yoz;SM-Oc1`SSf_%xP+BXqg>rf2I89ll61i&R9FVfGh| znlPA57gZ&!77=MjDbz$NVY!SuquKWM{&tb=Lb;%-VG4~J&xb-i%D}=q-s?i=&h_&} zZ2tL3N}wLxZV`a)gu05Z!b8&%auAMo85vHv*n&u`SlT|@cJ_-DGdrysEG9Cb5QVV(aXQxfN`xT5h1dSkaq3b3`D}*BBWEyV{r6-F3Zw|Pd znZnpu{ezhNDye>9<)CTpoam(^D%tZ_Z8hjf}VcHxI~ zsAY3rz^fccIk45ucSvmzn^rUo)o@6=PWDq&n8cENo9ridA~TsQn!zPnS*zImCu<9U z($9SAPx)t@rz>O3uFYpQol%x;gqhkV~hWexZ1go;`H7 z3Q?4SQ`^c6)YZ*v9R$$$DTB3?L07{mzLWuDWVP}|huN4A26u*6)wHtDkX|#i(Ii(` zLM$7@YNpIa<-OA=8)B0s{+;_z#EVUV{entsqD?>+Ct+rNF^BnA>w?1TV#J038!6ee zdR~IzOsYWX^3ecIUKSQa!VW#;IJ!cBnv_jMApj|1#rf{LentyIOuVB9ZYlIojfwti zb_|-*P@(pX<)|Uklf>we0CM#zy0^OmR#GM%4VQRQCXA9T??b>+(%@BqO;XK9Ql4%N zQsikPadvdr${=*0=BD-`O}X(gY!44|Hpa4ej#}B(hU#_)?acOe6^`qzqr zy~pCH#{d`2fa;=-W0rGyc7b$GHSFP8(f~I$$3_3pWDzfw;D=%`IJ++Z8V+5JcQKXE!0$NBHWFG_V4^W~ym4`W z+W-M+;Z+q*{7yn~^nKjuhDT!p`#4Z`#* zK=jK6$B^1%684=4LzE~f4fP9Bgi$v&+1%+!2={^8TR|*IV7*$a;QX2Dl?g5&L&5W~ zHFEG^Kw)PgDcv^93pVC~v z=oaqL*33u(*zX2eeXZ5lLq9D;f3Cy#Dd&PCVaL*z2v-G@I)X_lz@$*m9vv@85QW(y z(IE3~7MT51&LE~`H}9iFgYk9OJ<5PLU@6tFwm zxWygEbAhQT=LMOfG>f^k<qY1rT&a7c`@Dj!QU^Jrx!#$KM-D zzV(0~`r}X&2N45u>lTs8V#fD@nyHBK2bO2>Pz*V9WE=3i%`CAjOS7bxPK(P7Ggq3E z+g7iU$XDsgCYt-#c$UPOtPtAACtQw65c6c7?%>EY9XGItGAu)D)!}DS@`Y3WGZXHv z=-&G5JQ+V|B>9$aDE`Q!gv4Y6%jzrTXlgV;{vo08Fsi^MDrp;u$mF2JaC%T&I{bJ7 znm4>z-o5qPwHjbJu6&$*Z{7R0X3dwwcLdXQ+za@YA4Ugw8Vwv5_r{cN=BO78P5(beXy~Qr`=0) zMa;^N1G*9!21Z8x04{BjiQ38y8Dm5VnY`#bEH9NOv4;cLv3SAHcsAr9@pq1ffSgi} zV^q4?&vCdFK2M$T|J;Rjmlz^-pZr~(6#Fph>=hlI&kiRJPIg)0nF`7!LneHx87AVTu7l z|5BOnt(2MZB%ID!oJG?TwO zX@MmYbo0ij|7jbzC|w%?STkh%e4WhZ07Oqx;!UU?Q3OkX>Cgg{l&C!j2scc*6fyB> zNwmRaP~A*zmA~9l*TKCmI)H?i7+>rVJq)a66huB)%lLt0C8ept+2*oVh;mR#HvqoE z?C?{U+Jwp-l5cqidDmpy+lvdb4?o33-jLZ^Ykx~ReAD7jdEqM(n^87Wx;ju&YrXkP z3Bk`RPNFhLh`jCh&a7`1?p-MOT>_``&y9qcREOyDW_0aM6}108X-zEg(OpwmQgVFI zk5GBK$rw^mG2inU9E18ju${$-KPe&l}@8q&^AC>!5JAS@ji;c_zA@Pw&iW02!nWKVJHq?e^mc0Z2|dY_4i;~+=%>*NCO<|RYz|yh<4V_R zu7!##Gn6N`VQf*>j5+8{$SRl z_F${Tf&-6FgVjw~ef?c+I=JN_fd07)jK0zKvc!oG+lSS8f}wcR;j7&l^c>VtUBBnk zEeV&Z-Crh)^4aC0*c?tFtYE%0mHO(S#)LP0i}AoiTFOV!)*r-1Z#1E6fJS%{*Qp7p z2}ajgW=w*Ypq#<3xHUw;ZvLc0qlC320(Z?ACyOo2q;=;o5^0^MDrJ~ZI*mQ+Yt`^m zz)E9)B)y$UIk&8JQ}ozYWy;T>LTELvEg)WcNjSXx3|Xe(^1(?_?K?N9qk!TWJB%ul z<0xD3%su|`1R>9=#PCt{s!pl;)7kDD)$cjl1TXDsBK=q8UXtD_ZqW2 z!wHC5GqnB;apHycVQiV;e$I6G4)XJL2?P;TXVw~DR83rd|!_zXxC1DFIYe&h;AcSx+CcVX! zS&y3K?LFUkvcMJ7r9sh0>Vj0TbDH&p+E!eF_hsMRE%UDaKzLZ9?UfEJS?MCcpwD2) z=-cJ(-QT2~;ZL<|q~8bCxh4akb7<13&r+>}15^;8OR&RKB1se&hxAjl*}`CRe$t(W zD@*SdF)klQqSYSCE?3DAE{T_#bkDzpxQ@Pr;x?X5Q zEDRAbd2)-qAv4iJFNXPe@ss&RIuB%A2* zcDQ1l`%AJ)vhb`uyrZ2qMRj)gR$z&Ap&oV~I~{>-G|7mE0d7hAzs^y;+?43Bc68|a zo5gl?V8ZQq9z^C6SmhdG>fFF4t`BNMoG2sjZqyBQK!VA@2-qfx1o}VFb$UZNuY+=S zgH6h7toCbd3Zg;2T~hR_jOi|50sSmrOg!Ets4gVgm4HB)*Y;I48NP=RD?o>=hcOVU znSihVr^$D8q&({(b-LBs+7t%J4!Y25oAg)M%NJiQJL=3A&^w$fDh+NI^dileE@;ST zw!C{)*}s{xca;s+Zmf3OhPFqi3}TVyDy0z$-wGGaMIPT^x~o>b^h%GH*BT z+ERl|DS%y`jIM~%Vd6zV&15(^V1IGs^7v)-`W|R!*X;oRJw+8ufUs5%=(}tBoIZXK z=3?neAUTM+ntVvCoqj_H;vmeFB&MUoreHG`4giKj<0ghs?y3(m{@S~HNr4$J`3{m+ zo5Aqc>d;>xURW(%W;H-nkesVMzRSxuCZi-jD|s4bP)wB&jBbAR8^HL45D(M{}GN;-o%`xtA)#@bi&nbG1*7j z$dvZ&0H44<0iuFZO?*ny+F+&Snr)Ff6RdN45GnjQ>-h{9U>(c?u_OrEYyQW!luld~ zNNvqdVFK@Q0;xrQdo7_XpBnOJu%nF2zFnnuw~^#DrWn|FAu2u~Ap=pPfdn1{Vy&i@ zS5-v4((rjbRk{(MBH>8o?Y!~-^iTR^=!s|i3Nam>+A6qQp;8YdWh-vE{hj78ztsQs zUCALC{q0l@vWm=R;0h)+*+FC9oFhM5d3#)!^zcphXMNJ0fhV0Y!o6+#_fC zN{ok8g}aI5hp5g%BO(Hm(hRHd>`_7VP1W~$V5;x5tdP+4x9tAd%8miY;fCWsYF%#} zP(WVha)$X9&TB-Vmh6#fvG|}>Ege>dwk9^qd<)N%*;XGRIE5~9xTd+e&kD-mtiZ3; zEA-hltx^P>{^92dkETWTZHSckavBe_kRFvL3vpUexzx$;X==Kr>+1oS^1Y8n)Rf6T zjws7NBxynjw*y-_VwRmjC=2}+Bsp`W%0K&yJ5jh_y&TW|FpdkR-ma|fnOA>)MCt7uAtk3> zs_8NRLm(-5E<1wID=6Lh&rl)r&B{w&;SLHJ`9~Z&yE~9u)(DpnU@%nfiGlM>Geayg zFj@}tmRAvTp?da2-Xh2wAt5;&9}<@ywIm8Z@H1K%hg@TsL!$a58hF+)@8M`DQ7r_p zKTd|8EPP*8u)CgpG}??TWFwNHTht$EuuuzJ%;5})MK11@{8I2cZekd}o>o>BtM61> zAFzdLI^a}dGDOZ3nGsJl#DgalJUogRm#?>*6<)8%ddM5yZn z4ACjw^8eYx@+a!`=Yi=#L9GNQICI1bG8(8%QZ#YBgb(6sX$rYtnqGhekOK8QF`se0 z>p-TE3JJfCOHGEPjV$pVmFC6_Yc>0dc`^P~%c?^^ z5C#ACqZ>t2_Tpjm;)TLltx0M!JFCpX(kG(PgMyM5f(k#=@2blr2T5+K`t_4v;+XKm zm;m->#$ci-@|MzmE^$X0@6IS$kN1+Fop1Be1%4IMQTv;j>z@Evo*He5UfFNYynnw; zT=$$sbZAv{f+UxY^f;#Ze02NK=hjsl;4bM9B*rZ*5$BH_tV?#YqhVC?#c-UZlXoq{7R-DjaD zDq&2C29NZ`m;+DX^CTDd76quomT!6kl^a~5<0)VXF<=QpNuAkVEZ2h=v&G3-aq(!C z$PzrHpQ6lE|45Cfjs@OE-)Dv)qs#Rx21f_o*7<&=L@!o=Emr7FUZNexl2pv-7F$ptVZ1KqQn3(A#Yz-dvV*D1i( zDfABW;u306=qskDj zP9bpVAGFh&`6n7ruG^T)9c9n(xa2!nQju>M(cK}_OCQXNoQNf4cm8;n+u1=6SFT4! zdzA{ufb;)T`+jgfI5v4En&ymdHaqf!5RZW*!;Z^}ppvJhDa~es-Aj>>BIDO)c`#Ov zw=u6kfj8kPwnkPYMG+)X633W^ikB_YEiYohfvaI2S%xk{!h)1QUp}M5_06h-+rXJ7-FQ*rOsjLg1Bi+o z#+Z%+m0nsf5DpGKTrtjFzuK4lkvv@dKWZ5*_uEUM4{4YN88I=nDo8+Z3ATwQqZ4%e3ViSD|rpLxy^WWEi(9Y1$bt$KcR=Y*nqwu4kjx3s@rYbq?ZaBV;7 z>THSa2R^ft4;TfQ4M`g1XU8Zss6<<^<6g&$HGoDisShA#6l{ubOggpYE&#U&=}+zY z98J7c=8y)`4Vm{zPcr%Iv<2(5-bx9)2lP+Hd#d%j?7EWJzSkn#j(S5iv~m zHR}+WY z^PJ~AbDjIS&$;j7D4ag)z8>9vbwuOp>t#JkB)O-+l?=3q+}!T9qCO$(X@_-__IVwc zwa881{K~b*7mB8Y&gRS)s(-SGie3Q6W?g4jeku}lT?E2on2=MDYrJlf3p8H@8~R%I z?Ni$V_r=(oFHy<75m_{SS|GFEaF!mr#(sV>mGN`#PA9~ zY^~$rExycHEW-tfdEElX=27NPP?axRmhX3aHU*k{s_2F8NBJcr^+HJO5G_Mfgx@m% zRl2wr8=TGQ-c%)PQfVgvh%8%wCwDENU^PGpL`>Sgd@<%;v{HC;{aPdQ4~4al@kx8t zXD;>JVU2dS0nt3U+5qB*`nT{~4iD=^6T->qqMaRLZRYEF6(H#W-09BJQx{`;`Z1>( z1)5<8>@0xR-}Y7U411;jdOp*hlfJ^o$Ib_cQgMX(xSF3s0)SGu3A-tZ?eAi2RDZvetkhM3}U5ZX^pd0!8pQ*01b*MZTzHQgX zpy;uODH-)pv(U6i#e#}ELZJQL$}*&bBE7x$D6<=h_A(yLW^RT18{M53%urNo*9WPE zp$JWx_@)DF_qfpsJ&C6?q2>`*RKt2tQ=OREes;EKw<26y@)pK!=WXWKsh512W|z@s zGF-LmmNRlCX|2Ext$SjM?WC?mlX`X_Jov8GO;B9P4_FlQ$)z@S2r0KWW!Mtbe@Qm! zrjTR4Afg{{cSqIqQtdm=gpLw97l(v^9(|gIw&yG#P^Y?RZ^5D*sidFdBTp?vbfkof zr@z&YvC2}w4C-5b5ciqb0JTk%ltRzp;vN+F0-fD4I!(Se<(Ifl4 z+YtwT2HL3*Yq1QpTI^548*wU^z;m;cp6-rv`pZm!}NNpYK-` zPfF}AyJb>^e@Emtd1U40h$^3|rt_uR=FFD6IT~puKfxl}0RlyC{6ThlJ+W_xsjuX$ znh1f;eQGPPaBy@(yEDI%AN(ApUp6;77W^AM9dx7r%OJ|obV^X(Xq}apA_#tR?H#R| zAVR=IPP-lPoiaZ#Fi|uHrUR@d_$YmX9ISfclJv6RTtCO#`k*^+3+I|8iO)Z2p^B%V zyw)^3zP;oVP+qR^A{^X^$`97-$^k2~;InM(oiTGLIzW9DrbN!+0uYb&a&X8tg*kBO zK+CbUFrgd~0;yq85rVVJCyBVjMBF*@%ZInw<@-g%lURh2?8$Pl&4qU~gW|S)L|UyK zUq|;P>E-^`dZ5eOT%oC$`yN8%qbRabaR&D)sNKEu7m&E*uIQ(-_S$YvSJ%-ftHN@# zpwNsm|9LQl|1?93%8~_?TG)^a`W3vN4&PM(?JCf(jTguNM$E6~liLY_^!msyxuF)f zF^r`*JWC60%f8f4YvYr}rsE{B4mH#CDXnpmX^}B9bZpL4Y|b}zGUA)em7MKlqcS5> z8DuzpM3bIXQ`>?#Px~1z4~qR5m-J23)t ztQrJ54MID+5?@G{H-TSTDuG=yQ``GRc0P?2JvA!b+CSf!*s-y}FN@6for=YR zU*uS~4A!m*Ro3f;qx0Uh`lh;oG~KE4L{e7#Bqm826QnDsvb9e)Xy#A|HlBadg6T2z zi;$1IZ~5Er>3!?twuczV8o^MJOmZ=ZIo3u3T_d4=9l{rKp(CT!%^r-r&|y7tJuw-V z_U3-+8i&oOa)BBG)2A?R{z-csH)#W(8mz^Y`Lva-U1}z1+TPAEW_|30sW$oW^5SU= zE6$YX^eYg_-K||^EB$X&Hf;28Q6Bfm0QyadE4{|Rx_J35#sf=p)qLI zQ|a3FBgI}gYomP))r9K3%_V%1b-XLFaHztJ6L}^Vw4`=zLQWEfxW*NYO@s;cmy$!WF(A>WkesR|F zWrf09GW_DUbz_SpI3g zI;vvO>dI>FyeD9mG*v`TLtKiS#CKaicLyHb6_%VOXL55l)UJ^Ls0OAsmoa_Pej}uV z-^xoO*_L_#r)+as*S^L>^#LS+$&K9oT3^-eX$Al1Db6YKVW9g{ZBU`NpU^c*!_%C= zD!>-rVJ^NA<(Lo={(31WjIDB0R4|JGiQF_ad3qyLzoZ2!NdEl*_+~8{KZ*%bf*4B5 zw<8oRhMt^Kff{v1;D{x?{}Kep?ytyI|ZChn|W<$E__*OCg(V z;`9c!(WL-jex^Q%g!2UW16v=rE-t-!c$cJL4WSP9MW}TH)8dE0jK8Nb`li6W&I`=7r?00RSnHuo|?TFSzPQl(GlKl%+(LjSfb6HM}MX>};+S8&^2w zti-O~@qL1D6#;Hc4ETwjcJc~^jp&Q@K0m~ZB9dkU9eg)qBf3U&YEE!+u0r>G!++?^ zT{eUmBJNbDHe(zx(s-&)B>ao#EB1-I!)>en_2*aOBXJh-(P3aPqHkj|!O<2&J>^)I zjp6r(<{MKx6n-MVTS$Ie2$YN=Qv?uc_EQQnNh`9@A$rDL@OdvH@02iIUs7f+V z+4u3?VsJ}6gCvWjrt|Pid}SKST+@CSo7a=nSSjt9nSATd-U>yj#h!jJ)|?^1+#&z^ z?SFP5DmP<+Nv+UE+aC;7y&_GlZSSUbxP8h?+tgpT_U4`$EE?quVYOZOW9(A^qUBTt zP~gvQk~115DnVJaFoonBYSJ<%WY3frzGBenFeREaFbr~sYmQY>LiK&I57dr-qtEUoM35+HWTWuPo z==o~j!%FWB&~5F1{?!vu@R+GnEUb8ok*(}|NP8qU?A})epX|>34^gr29|}p|$wmsv zBV357HX6WtFNLupnq{h!%E;g!4#~YC^(_O#+V%I<_f0w^ly!fX z+tN`va#;scD0X$+c;WE^488Kigb5&xX{ARA3BBh-?r#dDU*^3o#$hO3SQu*&DfcLe zKEJJtI=8&Mmd)$Ka$bu*&5S|d@cnB~Ud8Ek#a(-FRz7Rfdx&0&i4JGPPSlGq#ETfo=3H32RZtUAQ4-}$HnxE{?X%*faF=dz_6 z&<0#zH97Sj_GCgz{PMZ}TuW&aCimc4e9x4IevZZ6+~|_e>GQABoZB`s-TiLvu)-`9x@6U}8_^DZ$h6BKN3_POs4> zwa)61Tbw+1Q$6W!B$`ZFEd~^%PUm$%hEDX25mI|WA?j-a>GHrloI4K?uZ&2eH08h> zW_W=>ZZsB|@=LqfuS-Lzh8A)KrAhBU@BhEBf$h&pvB%+qXADU9iSS*6s z`NFiGYs&1V*T~H1_i?OfuS`AC_$m!wm_SS^jMWBBYlCj{mE(S13gfl`XkIY7)QAhb zYRMIViT7C^$95?Yn~}yZ-28zq8K7Vd)@U@CnTLg$=b@_m=M(mlj)G{MG*<-%W{=bz z!gjr{d7ANtbqw3}b^u75a39i5r;rYAfLkkIYCP3zJlSXKKF!}_1(<6+qfKz0*etm2 zB_9N-IH(ji@}{maUH(`8UkV;myb%X^8Q$943YZly^%XC6eDmr%l71=E>2w0l;)D&h z^G?_zp6>$0O=u;+Yp(*s;5kFhIv5pusV0>{LMS3)ym6y*Xaa^{za8?5HbVQ|1go^- z_Lx-|iqUgsFdL|I^R_6L^>vyP&G$(06|Lyqkj0H`0e~rMRXS|wb++uFAs3f5?69GH z`$0nq;fU_8i3y-@Dfybj!BJa2v9^hm(lrklPK9m}`5Yp6e(l7Nu4!;u!)b0{T3dg7 z{mUV{{C9D4Xq8I5?wRy3jh&ZuOx->HTU)U0x4?%- z*R*#W0IAq-O9_8Io=>YPR>HEs8@)E?da^a|5jRPlK^s0YKk?_%Z^^7&linQk${I`` zb87k`7ZI2-{(FDPb+s(M+h*zGfW1tZq7tboG1t6^0Nmg=X$^ zH~n&LG`HsCc3~L!6|nYkki(W~CoJG`$eO9l=a2`3j%%UA=Jv)HPw@tA0qVUyyGgJ8 zKN9-tAF%s6iezNhHpl_hGC2i1*`b%}QTxyXFV%m?5oguoiAPNy58Oo$Ll_W09`hPK zo_y34?Z5}}FzP7(Bp8P^ zf4s?#*EwobaNyl_7$bmv0Wcx|<>Ym|!cp=6fuX@+oZ$FV;cr)if7=@zuX0qAeqa=E z7#l#9|FR7@o_U0@5i rIsZfQe7wNX#s2R}tT}speH=<|4Ya8Nxh@$Q1MoWoEWzuh2WS5Wix;1{ literal 0 HcmV?d00001 diff --git a/Parses.R b/Parses.R index d7a98c9..dd8172c 100644 --- a/Parses.R +++ b/Parses.R @@ -85,7 +85,7 @@ getInitial <- function(string, letter) { } split <- function(cell) { - + params <- unlist(strsplit(cell, ",")) values <- rep(0, length(states)) @@ -126,6 +126,7 @@ buildGraph <- function(model, desc) { #inputCode - the top layer of the model #outputCodes - all subsequent layers to be included in the model + inputNodes <- model$nodes$code[which(startsWith(model$nodes$code, desc$inputCode))] inputText <- paste0("[", inputNodes, "]", collapse = "") @@ -151,8 +152,15 @@ buildGraph <- function(model, desc) { outDist[[idx]] <- list(coef = coefVal, sd = model$nodes$confidence[nodeRef]) } - print("about to build network") - print(paste0(inputText, edges)) + print("Saving model prior to network modelling") + modelDefn <- paste0(inputText, edges) + save(modelDefn, file="buildGraph.RData") + + + #print("about to build network") + #print(paste0(inputText, edges)) + + net <- model2network(paste0(inputText, edges), debug = FALSE) @@ -167,6 +175,8 @@ buildGraph <- function(model, desc) { } allDists <- as.list(setNames(c(inDist, outDist), c(inputNodes, outNodes))) + + #print(allDists) cfit <- custom.fit(net, allDists) cat("about to calculate sample distributions") @@ -264,6 +274,8 @@ getCode <- function(name, nodeDF) { getValidEdges <- function(mapping, nodeDF, prevEdge = NULL, prefix) { #utils::str(nodeDF) + #save(mapping, nodeDF, prevEdge, prefix, file="validEdges.RData") + edgeCols <- c("inputNode", "outputNode", "impact") edgeM <- matrix(data = NA, nrow = 0, ncol = length(edgeCols), dimnames = list(NULL, edgeCols)) @@ -309,6 +321,8 @@ parseMapping <- function(mapping, prevOutputs, prefix) { nodeDF <- getValidNodes(mapping, prevOutputs$nodes, prefix) edgeDF <- getValidEdges(mapping, nodeDF, prevEdge = prevOutputs$edges, prefix) + #save(nodeDF, edgeDF, file="mapping.RData") + return(list( #New structure nodes = nodeDF, @@ -329,7 +343,7 @@ parseSheet <- function(fName) { sheets <- sort(delNA(match(names, mappings))) cat("starting sheet parse") - print(sheets) + #print(sheets) if (sum(sheets == refs) == length(refs)) { #read all mapping tables @@ -338,12 +352,6 @@ parseSheet <- function(fName) { p_op <- parseMapping(readXL(fName,mappings[3], startRow = 1), p_ba, prefix = "op") p_es <- parseMapping(readXL(fName,mappings[4], startRow = 1), p_op, prefix = "es") legend <- readXL(fName,mappings[5], startRow = 1) - - #print("building graphs") - - #p_baNet <- buildGraph(p_ba, desc = list(inputCode = "p", outputCodes = "ba")) - #p_opNet <- buildGraph(p_op, desc = list(inputCode = "p", outputCodes = c("ba", "op"))) - #p_esNet <- buildGraph(p_es, desc = list(inputCode = "p", outputCodes = c("ba", "op", "es"))) print("sheet load completed") return( diff --git a/app.R b/app.R index 9578432..d866c99 100644 --- a/app.R +++ b/app.R @@ -3,6 +3,7 @@ modules::import(shinydashboard) modules::import(shinydashboardPlus) modules::import(shinycssloaders) modules::import(shinyjs) +modules::import(shinyBS) modules::import(bnlearn) modules::import(visNetwork) @@ -12,21 +13,25 @@ modules::import(openxlsx) modules::import(zip) modules::import(DT) modules::import(plyr) +modules::import(magrittr) parser <- modules::use("Parses.R") +rw <- modules::use("reWeight.R") + addResourcePath("js", "./www/js") -layers <- c("Pressures to Bio-Assemblages", "Bio-Assemblages to Output Processes", "Output Processes to Ecosystem services") -transitions <- c("Pressures to Bio-Assemblages", "Pressures to Output Processes", "Pressures to Ecosystem services") +layers <- c("Pressures to Functional Groups", "Functional Groups to Output Processes", "Output Processes to Ecosystem services") +transitions <- c("Pressures to Functional Groups", "Pressures to Output Processes", "Pressures to Ecosystem services") impacts <- c("Very High", ">= High", ">= Medium", ">= Low", "All") thresholds <- c(0.97, 0.9, 0.45, 0.17, 0) impLabels <- c("Very High", "High", "Medium", "Low", "Very Low") ui <- dashboardPage( + dashboardHeader(title = "JNCC MESO online", tags$li( id = "dropdownHelp", @@ -82,6 +87,7 @@ ui <- dashboardPage( #menuItem("Habitats", tabName = "3", icon = icon("atlas")), #menuItem("Ingestion", tabName = "3", icon = icon("utensils")), selectInput("modelSelect", "Select MESO model", choices = c(""), selected = NULL, multiple = FALSE), + #downloadButton("download", "", icon = icon("download")), uiOutput("pressureList") ) @@ -143,7 +149,7 @@ ui <- dashboardPage( fluidRow( column( width = 6, - h4("Effect on bio-assemblage") + h4("Effect on Functional Groups") ), column( width = 1, @@ -155,7 +161,8 @@ ui <- dashboardPage( ), column( width = 1, - downloadButton("download", "", icon = icon("download")) + downloadButton("download", "", icon = icon("download")), + shinyBS::bsTooltip("download", "Template provides for decimal values in degs column OR degs:mins:secs. Longitude west of meridian must be negative.") ), column( width = 2, @@ -174,11 +181,13 @@ ui <- dashboardPage( fluidRow( column( width = 4, - checkboxInput("bbnDisplayNames", "Display Node names", value = FALSE) + checkboxInput("bbnDisplayNames", "Display Node names", value = FALSE), + shinyBS::bsTooltip("bbnDisplayNames", "Four MESO models have been defined thus far") ), column( width = 4, - checkboxInput("bbnDisplayEdges", "Display edge status", value = FALSE) + checkboxInput("bbnDisplayEdges", "Display edge status", value = FALSE), + shinyBS::bsTooltip("bbnDisplayEdges", "Edges are removed") ), column( width = 4, @@ -261,6 +270,42 @@ server <- function(input, output, session) { as.numeric(v) } + newNameMap <- openxlsx::read.xlsx("MBA_MESO_Nodes.xlsx") %>% + dplyr::select(hab, nodeType, Suggestion, node, newname) + #save(newNameMap, file="nameMap.RData") + + stripStr <- function(nodeStr) { + nodeStr %>% stringr::str_replace_all("\\.", "") %>% + stringr::str_replace_all(" ", "") %>% + stringr::str_replace_all("\\(", "") %>% + stringr::str_replace_all("\\)", "") %>% + stringr::str_replace_all("\\/", "") %>% + tolower() + } + + setNewNames <- function(wb, habName) { + + #habName <- substr(fileList[idx], 1, (nchar(fileList[idx])-5)) + + print(habName) + possNames <- newNameMap %>% + dplyr::filter(hab==habName) %>% + dplyr::mutate(node=stripStr(node)) + + newNodes <- wb$p_es$nodes %>% dplyr::mutate(node=stripStr(name)) + + print(possNames$node) + print(newNodes$node) + newNames <- apply(newNodes, 1, function(row) { + id <- match(row["node"], possNames$node) + print(paste(id, row["node"])) + possNames$newname[id] + }) + print(newNames) + wb$p_es$nodes$name <- newNames + return(wb) + } + getAvailableModels <- function() { fileList <- list.files(dataStorage, pattern = ".xlsx") @@ -276,13 +321,20 @@ server <- function(input, output, session) { wb$p_es$edges$values <- sapply(wb$p_es$edges$impact, getImpact) if (!is.null(wb)) { - modelList[[cnt]] <- wb - models <<- c(models, substr(fileList[idx], 1, (nchar(fileList[idx])-5))) + + habName <- substr(fileList[idx], 1, (nchar(fileList[idx])-5)) + + wb2 <- setNewNames(wb, habName) + + modelList[[cnt]] <- wb2 + models <<- c(models, habName) print(paste("Model file successfully loaded", fileList[idx])) + #save(tmp, file = "tmp.RData") cnt <- cnt+1 } } + #save(modelList, file="models.RData") updateSelectInput(session, "modelSelect", choices = models) return(modelList) } @@ -290,6 +342,10 @@ server <- function(input, output, session) { #parse on load sheets in the input sheet folder - replace with R Data modelList <- getAvailableModels() + save(modelList, file="model.RData") + + #print(load("modelList.RData")) + calcLikelihood <- function(layer, pressStatus, forPlotly) { @@ -301,7 +357,6 @@ server <- function(input, output, session) { thisModel <- modelList[[.selections$model]] - MEANPOS <- 1 MEANNEG <- 0 @@ -318,6 +373,25 @@ server <- function(input, output, session) { expr <- substr(expr, 1, nchar(expr)-2) expr <- paste0(expr, ")") + print(names(thisModel)) + + #Now do it in stages with one assessment per stage + + + + thisModel$p_es$nodes$confidence <- 0.1 * thisModel$p_es$nodes$confidence + + + #save(pressStatus, thisModel, file="beforeWeight.RData") + + + + if (sum(pressStatus$status=="On")>0) { + thisModel$p_es <- rw$reWeightModel(thisModel$p_es, pressStatus) + } #else nothing to do + + #save(pressStatus, thisModel, file="afterWeight.RData") + thisNet <- parser$buildGraph(thisModel$p_es, desc = list(inputCode = "p", outputCodes = c("ba", "op", "es"))) sampleDists <- cpdist( @@ -333,7 +407,7 @@ server <- function(input, output, session) { #print(sampleDists) #displayCols <- match(nodeCodes, colnames(sampleDists)) - sampleDists <- sampleDists[,match(thisModel$p_es$nodes$code, colnames(sampleDists))] + sampleDists <- round(sampleDists[,match(thisModel$p_es$nodes$code, colnames(sampleDists))], digits=2) means <- apply(sampleDists, 2, mean) stdDev <- apply(sampleDists, 2, sd) @@ -341,7 +415,7 @@ server <- function(input, output, session) { quantiles <- t(apply(sampleDists, 2, quantile, c(0.01, 0.25, 0.5, 0.75, 0.99))) print(paste("Building likelihoods from model, sample dists", length(thisModel$p_es$nodes$name), length(sampleDists))) #str(quantiles) - + if (forPlotly) { return(data.frame( name = thisModel$p_es$nodes$name, @@ -371,7 +445,7 @@ server <- function(input, output, session) { maxes = apply(sampleDists, 2, max), stringsAsFactors = FALSE )) - + } } @@ -397,7 +471,7 @@ server <- function(input, output, session) { #.selections$runOnce = FALSE print("Running calc") .likelihoods$p_es <<- calcLikelihood(0, newStatus, TRUE) - + .selections$pressStatus <<- newStatus } @@ -420,7 +494,7 @@ server <- function(input, output, session) { #status = status, stringsAsFactors = FALSE ) - + #This assumes all pressures are the same... setPressures(pressures) @@ -466,7 +540,7 @@ server <- function(input, output, session) { }) observeEvent(input$modalOK, { - + .resistanceScores["nr"] <<- -input$l1VH .resistanceScores["lr"] <<- -input$l1H @@ -476,7 +550,7 @@ server <- function(input, output, session) { .resistanceScores["ssgr"] <<- input$ssgr .resistanceScores["pressSD"] <<- input$l1PressSD - + .likelihoods$p_es <<- calcLikelihood(0, .selections$pressStatus, TRUE) removeModal() @@ -570,7 +644,7 @@ server <- function(input, output, session) { } else { edgeNet <- edges } - + print(paste(nrow(model$legend), length(palette))) legendDF <- data.frame( @@ -619,7 +693,7 @@ server <- function(input, output, session) { zerolinewidth = 10) # plot_ly(boxPlot, x = boxPlot[,1], y = ~Range, color = as.character(boxPlot$Group), colors = palette, type = "box") %>% - layout(xaxis = xform, showlegend = FALSE, title = title) + layout(xaxis = xform, yaxis=list(range=c(-1.2, 1.2)), showlegend = FALSE, title = title) } } @@ -668,10 +742,10 @@ server <- function(input, output, session) { }, contentType = "application/xlsx" ) - + makeLikelihoods <- function() { - - + + likeliTab <- as.data.frame( cbind( .likelihoods$p_es, codeVal = sapply( @@ -682,15 +756,15 @@ server <- function(input, output, session) { )), stringsAsFactors=FALSE ) - + likeliTab <- arrange(likeliTab, layer, codeVal) - + outputRows <- trunc(nrow(likeliTab)/7) outputTab <- NULL - + for (idx in 1:outputRows) { elementRow <- (idx - 1) * 7 + 1 - + tabRow <-c( name = likeliTab$name[elementRow], code = likeliTab$code[elementRow], @@ -702,9 +776,9 @@ server <- function(input, output, session) { max =likeliTab$range[elementRow+6] ) outputTab <- rbind(outputTab, tabRow) - + } - + likelihoods <- data.frame( name = outputTab[,1], code = outputTab[,2], @@ -720,10 +794,10 @@ server <- function(input, output, session) { } output$download <- downloadHandler( - + filename = function() { paste0("MESO-", format(Sys.time(), "%m%d_%H%M"), ".xlsx") }, content = function(file) { - + showModal( modalDialog( fluidRow( @@ -734,13 +808,13 @@ server <- function(input, output, session) { ) oldDir <- getwd() - + tmp <- tempfile("") dir.create(tmp) setwd(tmp) - - - + + + l <- list( pressures = .selections$pressStatus, nodes = modelList[[.selections$model]]$p_es$nodes, @@ -751,7 +825,7 @@ server <- function(input, output, session) { xl <- write.xlsx(l, "dataset.xlsx") #zipFile <- zipr(file, c("dataset.xlsx")) - + file.copy("dataset.xlsx", file) #print(paste("zip file complete", zipFile)) diff --git a/extract.R b/extract.R new file mode 100644 index 0000000..7515eeb --- /dev/null +++ b/extract.R @@ -0,0 +1,111 @@ +#R script to upload the existing spreadsheets and homologise them +library(magrittr) +fList <- list.files("data", pattern="*.xlsx") + +#Objective to create data tables with +linkCheck <- function(nodeType, nodeString, nodeStringCheck) { + nodeString <- stringr::str_replace_all(nodeString, "\\.", " ") + res <- sapply(nodeString, match, nodeStringCheck$Nodes) %>% is.na() %>% which() + if (length(res)>0) print(paste("Clean up error found in", nodeType, "mapping at", names(res))) +} + +getNodeVals <- function(nodeStr) { + params <- stringr::str_split(nodeStr, ",") %>% unlist() %>% trimws() + paramVals <- stringr::str_split(params, "=") + vals <- c() + lapply(paramVals, function(l) { + val <- l[2] + names(val) <- l[1] + vals <<- c(vals, val) + }) + vals +} + +#We want to build a node table and an impact table. +#Colnames of the node table will be +#Hab, Node Type, Node, Node Layer, Growth, .... + +#The edges table will be +#Hab, In Node, Out Node, Params, .... + + +sheetNames <- c("TestScenario", "Map_P_BA", "Map_BA_OP", "Map_OP_ES", "Legend") + +cleanNames <- function(namVec) { + stringr::str_replace_all(namVec, "\\.", " ") %>% trimws() %>% tolower() +} + +nodeTable <- tibble::tibble() + +for (wbIdx in 1:length(fList)) { + wb <- openxlsx::loadWorkbook(paste0("data/", fList[wbIdx])) + hab <- stringr::str_split(fList[wbIdx], "\\.")[[1]][1] + #get pressure names + + #Drop the time column no use at all.... + sheet <- openxlsx::readWorkbook(wb, sheet=sheetNames[1])[ ,-1] + pressures <- cleanNames(colnames(sheet)) + pressure_nodes <- sheet[1,] + + + sheet <- openxlsx::readWorkbook(wb, sheet=sheetNames[2])[ ,-1] + pressure_check <- na.omit(sheet[,1:2]) + sheet2 <- na.omit(sheet[, -c(1,2)]) + ba <- cleanNames(colnames(sheet2)) + ba_nodes <- sheet2[1,] + pressImpact <- sheet2[-1,] + + #linkCheck("pressures", pressures, pressure_check) + + + sheet <- openxlsx::readWorkbook(wb, sheet=sheetNames[3])[ ,-1] + ba_check <- na.omit(sheet[,1:2]) + sheet2 <- na.omit(sheet[, -c(1,2)]) + op <- cleanNames(colnames(sheet2)) + op_nodes <- sheet2[1,] + baImpact <- sheet2[-1,] + + #linkCheck("bioassemblages", ba, ba_check) + + sheet <- openxlsx::readWorkbook(wb, sheet=sheetNames[4])[ ,-1] + op_check <- na.omit(sheet[,1:2]) + sheet2 <- na.omit(sheet[, -c(1,2)]) + es <- cleanNames(colnames(sheet2)) + es_nodes <- sheet2[1,] + opImpact <- sheet2[-1,] + + #linkCheck("outputprocesses", op, op_check) + + legend <- openxlsx::readWorkbook(wb, sheet=sheetNames[5]) + + nodeType <- c( + rep("pressure", length(pressures)), + rep("bioassemblage", length(ba)), + rep("outputprocess", length(op)), + rep("ecosystemservice", length(es)) + ) + + + + res <- t(sapply(es_nodes[1,], getNodeVals)) %>% as.data.frame() + names(res) <- cleanNames(names(res)) + res <- res %>% mutate(nodeName=names(res)) + + nodeTable <- nodeTable %>% dplyr::bind_rows( + tibble::tibble( + hab=hab, + nodeType=nodeType, + res + ) + ) + +} + +mapNewNames <- function() { + newNameMap <- openxlsx::read.xlsx("MBA_MESO_Nodes.xlsx") %>% + dplyr::select(hab, nodeType, Suggestion, node, newname) + save(newNameMap, file="nameMap.RData") +} + + + diff --git a/reWeight.R b/reWeight.R new file mode 100644 index 0000000..b4bd9c7 --- /dev/null +++ b/reWeight.R @@ -0,0 +1,132 @@ +modules::import(magrittr) + +reWeightLayer <- function(nestedLayerTib, fudge=1) { + + for (idx in 1:nrow(nestedLayerTib)) { + #print(nestedLayerTib$data[idx]) + thisData <- nestedLayerTib$data[idx][[1]] + + #Calculate the overall depletion rate + #depRate <- ifelse(thisData$values<0, -thisData$values, 0) + #Re-adjust those weightings in line with the number applied + survived <- 1 + grown <- 1 + for (depIdx in 1:nrow(thisData)) { + if (thisData$values[depIdx]<0) survived <- survived * (1 + thisData$values[depIdx]) else + grown <- (1-thisData$values[depIdx]) * grown + } + #Update the edge weightings to reflect the combined depletion on the BA from each of the edges + + effDepRate <- survived - 1 + effGrowthRate <- 1-grown + #print(effDepRate) + if (sum(thisData$values)==0) newValues <- rep(0, length(thisData$values)) else + newValues <- round(thisData$values/sum(thisData$values)*(effDepRate+effGrowthRate), digits=3) + #print(paste(idx, paste(newValues, collapse=","))) + nestedLayerTib$data[idx][[1]]$values <- newValues / fudge + } + + return(nestedLayerTib %>% tidyr::unnest(cols=c(data))) +} + +assignWeights <- function( + edgesTib, + incode, + outcode, + value) { + for (idx in 1:length(incode)) { + ref <- intersect(which(edgesTib$input == incode[idx]), + which(edgesTib$output == outcode[idx])) + + utils::str(ref) + + if (length(ref)>1) stop("Error has occurred with multiple edges between two nodes") + print(paste(ref, edgesTib$values[ref], value[idx])) + edgesTib$values[ref] <- value[idx] + #Set the appropriate values + + } + return(edgesTib) +} + +reWeightModel <- function(thisNet, pressStatus) { + + print("About to recalc p - ba") + + #what is the depletion factor for each of the pressures applied to the BA? + p_on <- pressStatus %>% + dplyr::filter(status=="On") %>% + dplyr::left_join(thisNet$nodes, by=c("code"="code")) %>% + dplyr::left_join(thisNet$edges, by=c("code"="input")) %>% + dplyr::mutate(values=values * 0.9) + + print("before") + print(sum(p_on$values)) + + p_on <- p_on %>% + dplyr::rename(presscode=code) %>% + dplyr::rename(ba_code=output) %>% + dplyr::select(presscode, layer, ba_code, values) %>% + tidyr::nest(data=c(presscode, values)) + + newP <- reWeightLayer(p_on, fudge=1) + + + + print("About to recalc ba - op") + + #Repeat for the linkage between ba and op + bas <- unique(newP$ba_code) + ba_impacted <- thisNet$nodes %>% + dplyr::filter(code %in% bas) %>% + dplyr::left_join(thisNet$edges, by=c("code"="input")) %>% + tidyr::drop_na() %>% + dplyr::rename(ba_code=code) %>% + dplyr::select(layer, output, ba_code, values) %>% + dplyr::rename(op_code=output) %>% + tidyr::nest(data=c(ba_code, values)) + + newBA <- reWeightLayer(ba_impacted, fudge=4) + + print("About to recalc op - es") + + #Repeat for the linkage between op and es + ops <- unique(newBA$op_code) + op_impacted <- thisNet$nodes %>% + dplyr::filter(code %in% ops) %>% + dplyr::left_join(thisNet$edges, by=c("code"="input")) %>% + dplyr::rename(op_code=code) %>% + tidyr::drop_na() %>% + dplyr::select(layer, output, op_code, values) %>% + dplyr::rename(es_code=output) %>% + tidyr::nest(data=c(op_code, values)) + + newOP <- reWeightLayer(op_impacted, fudge=4) + + #Check for any more links through the system + print("About to recalc es - es") + + + ess <- unique(newOP$es_code) + es_impacted <- thisNet$nodes %>% + dplyr::filter(code %in% ess) %>% + dplyr::left_join(thisNet$edges, by=c("code"="input")) %>% + dplyr::rename(es_code=code) %>% + tidyr::drop_na() %>% + dplyr::select(layer, output, es_code, values) %>% + dplyr::rename(lo_code=output) %>% + tidyr::nest(data=c(lo_code, values)) + + newES <- reWeightLayer(es_impacted, fudge=2) + + incode <- c(newP$presscode, newBA$ba_code, newOP$op_code, newES$es_code) + outcode <- c(newP$ba_code, newBA$op_code, newOP$es_code, newES$lo_code) + value <- c(newP$values, newBA$values, newOP$values, newES$values) + + thisNet$edges <- assignWeights(thisNet$edges, incode, outcode, value) + + print("exitting reweighting process") + + return(thisNet) + +}