Implementando o Naive Bayes para variáveis categóricas
rm(list = objects())
library(lattice)
library(latticeExtra)
# Documentação dos dados.
# help(UCBAdmissions, help_type = "html")
# Carrega.
data(UCBAdmissions)
# Dados da forma de um array cúbico.
str(UCBAdmissions)
## table [1:2, 1:2, 1:6] 512 313 89 19 353 207 17 8 120 205 ...
## - attr(*, "dimnames")=List of 3
## ..$ Admit : chr [1:2] "Admitted" "Rejected"
## ..$ Gender: chr [1:2] "Male" "Female"
## ..$ Dept : chr [1:6] "A" "B" "C" "D" ...
# Gráfico de mosaico.
mosaicplot(UCBAdmissions)
![](data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAABUAAAAVACAMAAAC+2AIJAAADAFBMVEUAAAABAQECAgIDAwMEBAQFBQUGBgYHBwcICAgJCQkKCgoLCwsMDAwNDQ0ODg4PDw8QEBARERESEhITExMUFBQVFRUWFhYXFxcYGBgZGRkaGhobGxscHBwdHR0eHh4fHx8gICAhISEiIiIjIyMkJCQlJSUmJiYnJycoKCgpKSkqKiorKyssLCwtLS0uLi4vLy8wMDAxMTEyMjIzMzM0NDQ1NTU2NjY3Nzc4ODg5OTk6Ojo7Ozs8PDw9PT0+Pj4/Pz9AQEBBQUFCQkJDQ0NERERFRUVGRkZHR0dISEhJSUlKSkpLS0tMTExNTU1OTk5PT09QUFBRUVFSUlJTU1NUVFRVVVVWVlZXV1dYWFhZWVlaWlpbW1tcXFxdXV1eXl5fX19gYGBhYWFiYmJjY2NkZGRlZWVmZmZnZ2doaGhpaWlqampra2tsbGxtbW1ubm5vb29wcHBxcXFycnJzc3N0dHR1dXV2dnZ3d3d4eHh5eXl6enp7e3t8fHx9fX1+fn5/f3+AgICBgYGCgoKDg4OEhISFhYWGhoaHh4eIiIiJiYmKioqLi4uMjIyNjY2Ojo6Pj4+QkJCRkZGSkpKTk5OUlJSVlZWWlpaXl5eYmJiZmZmampqbm5ucnJydnZ2enp6fn5+goKChoaGioqKjo6OkpKSlpaWmpqanp6eoqKipqamqqqqrq6usrKytra2urq6vr6+wsLCxsbGysrKzs7O0tLS1tbW2tra3t7e4uLi5ubm6urq7u7u8vLy9vb2+vr6/v7/AwMDBwcHCwsLDw8PExMTFxcXGxsbHx8fIyMjJycnKysrLy8vMzMzNzc3Ozs7Pz8/Q0NDR0dHS0tLT09PU1NTV1dXW1tbX19fY2NjZ2dna2trb29vc3Nzd3d3e3t7f39/g4ODh4eHi4uLj4+Pk5OTl5eXm5ubn5+fo6Ojp6enq6urr6+vs7Ozt7e3u7u7v7+/w8PDx8fHy8vLz8/P09PT19fX29vb39/f4+Pj5+fn6+vr7+/v8/Pz9/f3+/v7////isF19AAAACXBIWXMAAB2HAAAdhwGP5fFlAAAgAElEQVR4nO3dC7xlY/348efMlRkMJkMRmsklhIxbhYbqR3JJyKVSUSKFolIqP/fLuKfk70e5JKmfVCTyW7kVUi6Rew1R7pcYY65n/fez9t7n2c+ZZ6919vOc7/fcPu/Xyzlrrf3s9eyZtedjnbNvJgcARDEDfQMAYKgioAAQiYACQCQCCgCRCCgARCKgABCJgAJAJAIKAJEIKABEIqAAEImAAkAkAgoAkQgoAEQioAAQiYACQCQCCgCRCCgARCKgABCJgAJAJAIKAJEIKABEIqAAEImAAkAkAgoAkQgoAEQioAAQiYACQCQCCgCRCCgARCKgABCJgAJAJAIKAJEIKABEIqAAEImAAkAkAgoAkQgoAEQioAAQiYACQCQCCgCRCCgARCKgABCJgAJAJAIKAJEIKABEIqAAEImAAkAkAgoAkQgoAEQioAAQiYACQCQCCgCRCCgARCKgABCJgAJAJAIKAJEIKABEIqAAEImAAkAkAgoAkQgoAEQioAAQiYACQCQCiiHo2Qt/N9A3AcgJKGR1P/Tri8887vs/u+mBBf20x5dv+f6Bm3WZI/tpd0AKAooIxpnU2LRfc8PdPaNePXf75XvGLfeJK/5T23aUaTV21Xfvc0t37713v8OYX7SZ+S+Na3YQ0EUv9H1s58MxohFQRPjh8TPqHdvuxB83Nt121hfGGbPed85/qbHh+S8ubUcsuemOe273jnouj83zv57z5WKzGbfCyqPr+9jkn732fltt44w2M//rqO9s3FlAf7Oiedc/+v5H63A4RjYCiigLl7MZW907ezzMmFk9K/87xQ740PVvFGtPn2DHH1Isn15k8748X/DnbYvFDXr9eP85u/GetlNf2VFAX59UG719X0d3OhwjHAFFnM2KE1Bv0/lmiZ6gHm0vXva37sLntjHme8XStc2A1jJcnE2aP3q7mV2con6m7cy3dBTQB+3olfo6utPhGOEIKOJsZUvzEW/TxWbZ5uKp9tLlH2i9dMFbzQ3FQuYCml9RLH/P281F9R/xn2038187Cui8t9RGf6yvozsdjhGOgCLONjZju3qbLjOTG0u3Fw38lX+Nd5n6LztvbgnovcXyEd64req/Gj2m3cz3dfY70DunL7Vz2xgnD8fIRkAR5/2LB/QnzYAuKn4y/3Cva7xvwqLi+y0tAX2gWL6oddj9ZvQaxc/R89rM3GFAATkEFHHKAvrLIotZr2v8+Oz699aAXmUXRz/aOuxAs8sFxYhL2sxMQDFoEFDEKQvoPvaySQvbXLM1oAfZxW+2XvrKRHPd68VD/NN7P0F09jmbLbfMRkf+pDWg3Xd+e4Nf5fk1Wy6/5NQDHrYbLp4+adLG+9zdcr0HTjipufjsWbttvvLYN629xxVvtNngDc/zv35rq1WWXGKVDxz3VM+mxpRXb7Hcsu85yG0O7AnDHgFFnJKA1p/i1Pa5QC0BvbmrtnSo97P62WbqIvuEqJpb/ev9amXj2IC+cepXPmYf8/nZvC/VN076Y/6f3eqL4+vnv09dc9yuqxuzbXPnE40ZtfJ4O+BvoQ29hufP7GwveYu9fOzXFoSmXPridrvGSEBAEackoE8Vafliu2s2Ajr377//zOjaeeZvvQu71zK187/HbFjNbq0XvLC3MZM/9t8HvtkF9PlGTE/btJnVtf6yRnNxneL8def6SqOIZ9QWT5mdz79rP2P+HdrgD88fsa3c/+l89rfs1h0WhqYc82B41xgRCCjilAT0zqIsR7W75i3uPHKJz/yp14W/M2PtY+Db20tHP+G2PzjNmPXto/jzj+gJ6KKnn9ylWNnwqod/tX6x1DXtsoev3bJYvN9e7fZfHO6K+NISxuxTLHWvYeaENnjD89fXqS1vXzzy9Rm7+biWKd/1v4/edHCxdERw1xgZCCjilAT0GtPITVg9oKOKr8tM2/zL3gsndzZ7uF18tWfzf95aW72zvnx0M6B54/mmG75eW3ptBbu46vO1xflr28XGq+mfdUW8rLZ0Yn3rHuODG7zh9ZdMXVks3lXc2Fd6ppxeRPKonvPkwJ4wEhBQxCkJ6E1F/b7c7pqNH+HnP3HrycXLPUd90T3c9Pgo83v7fdFUe8mys5vbv2Kj1VhufRT+R3b53GLx627zmXbxvPqIBa6IJ9aWNnmuWPzdycEN3vDu1e1ZcP10snslu/2HPVP+oNj6ov1Nw1Zt9oSRgIAiThHQXbxNlzYCWrwc0uzd7potDyK9Xjxeb77Tc9kRZq36Y+/FeZ75fmPzwhVrK59urLQGtHhE/mfFYvECpjOKxetbz4DH9xTxB/XfGlz8SPPh/cU2eMMfs5dOaWzey658pteUub1Za7fbE0YAAoo4RUA/4G06vxHQl4v4rdHumq1PY5prfzQ3419pXPTGm8xhjxbuKN6qaa36U+/rP0E3n+3UJqDXu4AWL/b8emO4K+IdpmHyJ/93QXCDN/yn9pJ3NDZ/2TRPNlsDukFtceV2e8IIQEARpwjoRt6ms5rvwlF/QOfJNtdsDWh+QLFyZeOii0wv19a3/9ouH90Y1Cagv3cBfTAc0HwHt+NNHw5uaB3+/WJzYy/H2JV1e02ZT28GNLQnjAAEFHGKgL7N2/QNs0594ZtFSE5sc00voGcUK2c2Ltqkd0Ab5fuRXf5cY1B8QF/d1e15vfmhDa3DZ9qtazf2co5d2aDXlC0BDewJIwABRZwioJO8TR81W9YX7i46MqXN03m8gBY/J5sf1Vf+ZMxdPcPq73T3gBvVfO+8+IDm+T2HbzSqkblfhDe44efbjSs0rniuXdmm15QtAQ3sCSMAAUWcnYpU/Ktly/wpjXdMzvOPFRceHr6mF9DiNM80ng26j1nXPQhTPC5jDiiWi3fAW/o/9QvuTQhozX+uO7h4w9ETwhvc8OL3BqMbN+h4u/L5XlN6AQ3tGsMdAUWc+rPIz2jZ8nNj/rex+FjxksaeX236vIDub5fXr1fqufHmFDfslQn2ogkv2uWXiqs03ozkotiA3jy58aqnR5Y0xdvlLbbBG15/1dH99RHFi0t/0mtKF9DQnjACEFDEqb8t8rLujZSeWsmsPLe5ckXxWswxF4au2RrQp+0naHRdV7/gRDPqqZZxny7G1Z9VWfw8v1zxTPpn3hYb0Kt63jfPvuXo5YEN3vB8c7ub4+vLH7R/2Fd7TekCGtoTRgACijiL3lf07U3n13/T+fqFKzaf0V44p/7bwL3+3rNlwa8/8sNi4XcuoK/u3PIT72tvMZu1znBdMe6txSMy/1MsL/PfN95y0grj7OKh9THF7ynrv0EtfuI+tlgsAtp4Lf58m/L672Yv6Tk1nGbMUq8GNnjD7Sm1MRsUz6R6cUzPiWUxZf1PUgR02eCuMTIQUER6cmq9kWM32XG397zFdueTrc8iv26l+qU7nffX5xb8+w+XfPUtpuuh4pLzigt+8fQjv5tpX4k0vvGSofxrxuzYOsET9f1/2y4vqD+kZL3zx/Zr4yn8R7pqFs86qj9SXwS0sa+/2+VVi8VzzdhLipv4w9qmc0IbvOF5d/HOTva97RbZs+H3LXBT/nd9hA2oeSW8J4wEBBSxntvJtOo60n/2znMHTfQuN8vU32bz/6Z41/pI/ZcAb5z1odraEkfMvL5x9Qtn7tEY8v5T38jzWas31nZ97epiZ9+e+cLrM49d1S5PPf6X+YXHr2sXVzh65guNgC71rZnP5r84uf4GS4ec8uc8P6W2sOlxPzxtR5tlm7vFNnjDa+fE9gKz0w9OmlH7trMNZXPK1Y+bad/1swjonqf8fvE9YWQgoIh38yeXaYZw0v5/Xezil07dZkJPKN9zev3lRre7eI5fZdsTZjXGNt8nrv5Id826LZW17xDyzCeKJwkd2934IDpjHuy5jnlfy/AHm68lNebu5vvTmeK3ozftuFSzyTcVcyy2wRtes/CCtzfWN/v5Iu9mGvNy3gioMYctvieMDAQUKRb87fJzTjj+nJ88sCh8+fw/Xfk/Jx97+gW3vJQ+17OXnXza3dXDysz74xXfPeHS219sv6G37ocuPu247/2i+mPmKveE4YiAAkAkAgoAkQgoAEQioAAQiYACQCQCCgCRCCgARCKgABCJgAJAJAIKAJEIKABEIqAAEImAAkAkAgoAkQgoAEQioAAQiYACQCQCCgCRCCgARCKgABCJgAJAJAIKAJEIKABEIqAAEImAAkAkAgoAkQgoAEQioAAQiYACQCQCCgCRCCgARCKgABCJgAJAJAIKAJEIKABEIqAAEImAAkAkAgoAkQgoAEQioAAQiYACQCQCCgCRCCgARCKgABCJgAJAJAIKAJEIKABEIqAAEImAAkAkAgoAkQgoAEQioAAQiYACQCQCCgCRCCgARCKgABCJgAJAJAIKAJEIKABEIqAAEImAAkAkAgoAkQgoAEQioAAQiYACQCQCCgCRCCgw9N1+yg7nDvRtGJEIKDBwbvrwUsasMuOdy6934usp+znqfebY/rpN6AAB1ZN2lsA5xvB0iDm49vWxjczHvc2/WOm34fEXrh8s7ZUEdEAQUEHXr9Pdupp2lsA5xvB0sjnEfrvLdM1u3Xx+10/C45cZ2x3a/GvuHQOCgAr6qMm89fZnCR9bf37ec3LBOcZIckY9oAvHmH9722cHR+f5m98c3ExABwYBlfPUEuaj3ob2d/LNp8zJe04uOMcYSRoBfdxM87c/9Ux4/MprBjdz7xgYBFTON4+bPOqfrRva38kXvGG/Nk4uOMcYSRoB3W/Mtfbbqydu84GNjp776qHrmkvcqr3k/k9Pm7D5r//yIWPGj/+kd8nTh62z1Fb7ce8YEARUzJzVXjrCHNm6pX0CF91vvzZOLjjHGElqAZ396NXbrvxLu/LQtO8syu8Ys9vcmz5gA9pczfN5B824/m+XvX2fZx9cavUHH3ym5ZJFJ21646sPf2Ms944BQUDFnP/5/PFRK8ytr7izhL9/d+eNFxw+eamdnsl/vfaEzW6pXXjrXiuMz/PGyQXnGCNLLaCXG/Nd+zvwfNE6G9vf3uxp7sxPrgW0ZfXA1e0dIftWnk9aq9fAcU/Yq36Pe8eAIKBSut9ZO6vcpfhBzDtLuHp/s8peX7l0R/Pucz/8w6PHTHwqzx//2ZK1gDZOLjjHGFnsj/AHmHWLxw1vNPvbb8eY8/Lv1u45bvXxrsPt0mtPNALqLpm73AeL3fDzycAgoFL+b5val8xsZpe9s4Tu8ebmPF/wNvP52knEkeZMe8na4+3X4t8G5xgjiw3onHXNvnb5PDNls6233XXXHa8pAupWLzKnN8cX9w53yd31axLQAUJApex4Ve1L97rmz3ne6yxhymr2677G/vSeFU+jzqcvFlDOMUaI4kGk+5YwF9eWzzUHNDfbgLrVc82hzQuKe4e75Hbz4eI7T3IbGARUyKPj11irZkXz6TzvdZawYvGElcPMbbm96CC7snhAOccYIeqPwn/fTHwwz681mzQ324C61VvNhosai8W9w13yWteKxTM4fsC9Y0AQUCEHH198m73U+Od7nyX0KaCcY4wQJ5sv1L5272zWez1/fYX678wXdhcBdatvTDM/aIxfbtlaSlsGbmhOrC08vZY5ZkBu/khHQGX8Z5kn6wv7mZN6nyX0KaCcY4wQh5pd7LcXVjaf6c4v6zKH/ObeC7d4qQhoy+qtE82BNzx8Ve3n/A3MF795bcsl2Vjzhd+c/V9nm8MG+k8yIhFQGWe+u7Fwk1llXq+zhClT7devmD/mNqD2/CPfaJz9WpxccI4xkly0wzJm3PYza0s3jjKbPJf/4eNrTXr/Uc/Vf4TP3Wr+xKfWXOLtn/5Hnl8/deJe81svuXOHtyyx3XNXm0k7PzCwf5YRiYCKePWtzbPFhZNrP3x5Zwnd4yfbC/Y19qUnd9ffhGeqsS/lrJ9ccI4xMr2xcGHLS3hPMz8duJuCPiOgEk59m1l+p+Jn+O/uOMqM3r31LOH0LYzZ+vI7d5popu5uAzphx5sufH+X2ezYnpMLzjGQH138hgeDHQEdWN0Lg28cgpHuYPPsQN8E9AEBBQahLT8y0LcAfUFAgcHnb8vfM9A3AX1BQIFB56gd7hzom4A+IaAAEImAAkAkAgoAkQgoAEQioEG9PpBYwbXbjTLjVnv7xBW3vTVpPwuu3mujVSetvuW3ft/+T/DTD9bmevvWG6+0wubfejI04JKdJxkzbsryxpgdWraMX2mp2pY2n1c+oASPV38dGKcvhyhC5VHt2OJ3g/4zyO9QfUZAg3p/ILGG95vz83zuTDPxHwk7uXrlNS9/bFH3P//f1KXK/nUWc+X5nJ+vN+6M4LhDzZdq2+c98ZXP+1v+c+/q9yXcPCmix6tfDozTx0MUofKodmzxu0H/GdR3qD4joCGLfSCxhk/W7/4bmwvi93Gi2X9OfemJd5aN26c+V56/PsPMDA04pf5ZkfnPju695X0vxt88KbLHqz8OjNPXQxSh8qh2bPG7Qf8ZzHeoviOgIYt9ILGG/ep3/x0SfqT5pVl/fmPxjZ36MFfNrFFjHwsMaHzYbv7ko7233DgIX3sqe7z64cA4fT5EESqPascWvxv0n8F8h+o7Ahqw+AcSa6jf/V9bqf75YjEWrWFu7GSuwgzzrcCA5r27bMugIXy80g+M0/dDFKHyqHZM8qAP4jtUBwhogPeBxGrs3X/RXR/6yNPRe7jZjJ1fPao5V8NnzfsCAxr37iMfKdkyaAgfr/QD4/T9EEWoPKodkzzog/gO1QECurjWDyRWtJ952yZLd+11/mvRe/i+WbfPc/X8UzvBvCMwoH7vfnXjJ3pv+cATgdEDS/p4pR8Yp++HKELlUe3Y4neD/jN471CdIKCLa/1AYkX27t/95LdGr3Bv7B6+bbbqYK6Gs817AgPOMOMmTVrGmH+VbBkspI9X+oFx+n6IIlQe1Y5JHvTBe4fqBAFdXMsHEmtq3P2/Y9aO3cNpZo3O5qrP98nAgPrpweszHi/ZMlhIH6/0A+P0/RBFqDyqHZM86IP3DtUJArqY1g8k1tS4+z9gzDORe7iuz/87b/mn9mHz48CAxi+ozpxVsmWQED9e6QfG6fshilB5VDsmedAH7R2qIwR0Ma0fSKypcfd/Of6f2NzlzTc7mqvmhQkrzA4MGEKPwosfr/QD4/T9EEWoPKod41H4KgS0N+8DiTU17v53mKnRT4w7y4y/o5O5cvvREd8LDei5d5/+Ru8tg4z88eqHA+P0+RBFqDyqHVv8btB/BusdqjMEtDf/A4kV7Vu/++9p/id6F4v2Msv+qrH8pznVc+ULTzF7BatwcvPevV53z5YvRN8uSfLHqx8OjNPnQxSh8qh2bPG7Qf8ZrHeozhDQXnp9ILGiHWvTdT++nzk44b668OixZsvv3nr/774/Y5uy3Wxtzpyfz37oivVGH7EwOOBgc1Dt+oteu/WtzS2Hml3ib5cchePVHwfG6eshilB5VDu2+N2g/wzSO1SHCKhvsQ8kVvPD0cYs96a1dr89bTf/PnbGimMnb7jPDYtKBh1mapYcM+Xd35wVvPzeHSYYM2pS7YuZXt9y0Q7LmHHb988LrPuTwvHqpwPj9OkQRag6qh1b/G7QfwbrHapTBBQAIhFQAIhEQAEgEgEFgEgEFAAiEVAAiDQMA/rYFDMYLHebvTEXjhOcYsJldoobly4fNbp4jfhra/Vhh8Gh4860G++bXKxMvlv8+H0o6u+ic0te3Jzxjkn9sb+NFzT3t3s/7G30x5t7m/fOfthdW1N7Xv96+KhOrjf6s83rzV5b6raV6Hq/+P2wb4ZhQK8cgOMZcra9MZ8RnaJ4KcfJVaOKJ0E/0KcdBocWz3e+uLHSH6/GKTe2w7+EaPs3Zzynf/b3bHN/y/XH3lZq7u2f/bG39m5rzjO9s+u9rXm9h2RuV5V+fhJtrGEZ0C2ygbdLM6BfE5vikGZA9ywbdXmziqtV7jA49JhmQD9YW9leJaDXJ/7F9MlXWgP6kfT9Ldsa0F+m7u3nrQGdkn7r2lmnNaA/6Pv1ftwa0LfK3b52ugioGALqIaBhBNQioIkIqBACGouAZgS0CgGVQ0A9BDSMgFoENBEBFUJAYxHQjIBWIaByCKiHgIYRUIuAJiKgQghoLAKaEdAqBFQOAfUQ0DACahHQRARUCAGNRUAzAlqFgMohoB4CGkZALQKaiIAKIaCxCGhGQKsQUDkE1ENAwwioRUATEVAhBDQWAc0IaBUCKoeAeghoGAG1CGgiAiqEgMYioBkBrUJA5RBQDwENI6AWAU1EQIUQ0FgENCOgVQioHALqIaBhBNQioIkIqBACGouAZgS0CgGVQ0A9BDSMgFoENBEBFUJAYxHQjIBWIaByCKiHgIYRUIuAJiKgQghoLAKaEdAqBFQOAfUQ0DACahHQRARUCAGNRUAzAlqFgMohoB4CGkZALQKaiIAKIaCxCGhGQKsQUDkE1ENAwwioRUATEVAhBDQWAc0IaBUCKoeAeghoGAG1CGgiAiqEgMYioBkBrUJA5RBQDwENI6AWAU1EQIUQ0FgENCOgVQioHALqIaBhBNQioIkIqBACGouAZgS0CgGVQ0A9BDSMgFoENBEBFUJAYxHQjIBWIaByCKiHgIYRUIuAJiKgQghoLAKaEdAqBFQOAfUQ0DACahHQRARUCAGNRUAzAlqFgMohoB4CGkZALQKaiIAKIaCxCGhGQKsQUDkE1ENAwwioRUATEVAhBDQWAc0IaBUCKoeAeghoGAG1CGgiAiqEgMYioBkBrUJA5RBQDwENI6AWAU1EQIUQ0FgENCOgVQioHALqIaBhBNQioIkIqBACGouAZgS0CgGVQ0A9BDSMgFoENBEBFUJAYxHQjIBWIaByCKiHgIYRUIuAJiKgQghoLAKaEdAqBFQOAfUQ0DACahHQRARUCAGNRUAzAlqFgMohoB4CGkZALQKaiIAKIaCxCGhGQKsQUDkE1ENAwwioRUATEVAhBDQWAc0IaBUCKoeAeghoGAG1CGgiAiqEgMYioBkBrUJA5RBQDwENI6AWAU1EQIUQ0FgENCOgVQioHALqIaBhBNQioIkIqBACGouAZgS0CgGVQ0A9BDSMgFoENBEBFUJAYxHQjIBWIaByCKiHgIYRUIuAJiKgQghoLAKaEdAqBFQOAfUQ0DACahHQRARUCAGNRUAzAlqFgMohoB4CGkZALQKaiIAKIaCxCGhGQKsQUDkE1ENAwwioRUATEVAhBDQWAc0IaBUCKoeAeghoGAG1CGgiAiqEgMYioBkBrUJA5RBQDwENI6AWAU1EQIUQ0FgENCOgVQioHALqIaBhBNQioIkIqBACGouAZgS0CgGVQ0A9BDSMgFoENBEBFUJAYxHQjIBWIaByCKiHgIYRUIuAJiKgQghoLAKaEdAqBFQOAfUQ0DACahHQRARUCAGNRUAzAlqFgMohoB4CGkZALQKaiIAKIaCxCGhGQKsQUDkE1ENAwwioRUATEVAhBDQWAc0IaBUCKoeAeghoGAG1CGgiAiqEgMYioBkBrUJA5RBQDwENI6AWAU1EQIUQ0FgENCOgVQioHALqIaBhBNQioIkIqBACGouAZgS0CgGVQ0A9BDSMgFoENBEBFUJAYxHQjIBWIaByCKiHgIYRUIuAJiKgQghoLAKaEdAqBFQOAfUQ0DACahHQRARUCAGNRUAzAlqFgMohoB4CGkZALQKaiIAKIaCxCGhGQKsQUDkE1ENAwwioRUATEVAhBDQWAc0IaBUCKoeAeghoGAG1CGgiAiqEgMYioBkBrUJA5RBQDwENI6AWAU1EQIUQ0FgENCOgVQioHALqIaBhBNQioIkIqBACGouAZgS0CgGVQ0A9BDSMgFoENBEBFUJAYxHQjIBWIaByCKiHgIYRUIuAJiKgQghoLAKaEdAqBFQOAfUQ0DACahHQRARUCAGNRUAzAlqFgMohoB4CGkZALQKaiIAKIaCxCGhGQKsQUDkE1ENAwwioRUATEVAhBDQWAc0IaBUCKoeAeghoGAG1CGgiAiqEgMYioBkBrUJA5RBQDwENI6AWAU1EQIUQ0FgENCOgVQioHALqIaBhBNQioIkIqBACGouAZgS0CgGVQ0A9BDSMgFoENBEBFUJAYxHQjIBWIaByCKiHgIYRUIuAJiKgQghoLAKaEdAqBFQOAfUQ0DACahHQRARUCAGNRUAzAlqFgMohoB4CGkZALQKaiIAKIaCxCGhGQKsQUDkE1ENAwwioRUATEVAhBDQWAc0IaBUCKoeAeghoGAG1CGgiAiqEgMYioBkBrUJA5RBQDwENI6AWAU1EQIUQ0FgENCOgVQioHALqIaBhBNQioIkIqBACGouAZgS0CgGVQ0A9BDSMgFoENBEBFUJAYxHQjIBWIaByCKiHgIYRUIuAJiKgQghoLAKaEdAqBFQOAfUQ0DACahHQRARUCAGNRUAzAlqFgMohoB4CGkZALQKaiIAKIaCxCGhGQKsQUDkE1ENAwwioRUATEVAhBDQWAc0IaBUCKoeAeghoGAG1CGgiAiqEgMYioBkBrUJA5RBQDwENI6AWAU1EQIUQ0FgENCOgVQioHALqIaBhBNQioIkIqBACGouAZgS0CgGVQ0A9BDSMgFoENBEBFUJAYxHQjIBWIaByCKiHgIYRUIuAJiKgQghoLAKaEdAqBFQOAfUQ0DACahHQRARUCAGNRUAzAlqFgMohoB4CGkZALQKaiIAKIaCxCGhGQKsQUDkE1ENAwwioRUATEVAhBDQWAc0IaBUCKoeAeghoGAG1CGgiAiqEgMYioBkBrUJA5RBQDwENI6AWAU1EQIUQ0FgENCOgVQioHALqIaBhBNQioIkIqBACGouAZgS0CgGVQ0A9BDSMgFoENBEBFUJAYxHQjIBWIaByCKiHgIYRUIuAJiKgQghoLAKaEdAqBFQOAfUQ0DACahHQRARUCAGNRUAzAlqFgMohoB4CGkZALTE46goAACAASURBVAKaiIAKIaCxCGhGQKsQUDkE1ENAwwioRUATEVAhBDQWAc0IaBUCKoeAeghoGAG1CGgiAiqEgMYioBkBrUJA5RBQDwENI6AWAU1EQIUQ0FgENCOgVQioHALqIaBhBNQioIkIqBACGouAZgS0CgGVQ0A9BDSMgFoENBEBFUJAYxHQjIBWIaByCKiHgIYRUIuAJiKgQghoLAKaEdAqBFQOAfUQ0DACahHQRARUCAGNRUAzAlqFgMohoB4CGkZALQKaiIAKIaCxCGhGQKsQUDkE1ENAwwioRUATEVAhBDQWAc0IaBUCKoeAeghoGAG1CGgiAiqEgMYioBkBrUJA5RBQDwENI6AWAU1EQIUQ0FgENCOgVQioHALqIaBhBNQioIkIqBACGouAZgS0CgGVQ0A9BDSMgFoENBEBFUJAYxHQjIBWIaByCKiHgIYRUIuAJiKgQghoLAKaEdAqBFQOAfUQ0DACahHQRARUCAGNRUAzAlqFgMohoB4CGkZALQKaiIAKIaCxCGhGQKsQUDkE1ENAwwioRUATEVAhBDQWAc0IaBUCKoeAeghoGAG1CGgiAiqEgMYioBkBrUJA5RBQDwENI6AWAU1EQIUQ0FgENCOgVQioHALqIaBhBNQioIkIqBACGouAZgS0CgGVQ0A9BDSMgFoENBEBFUJAYxHQjIBWIaByCKiHgIYRUIuAJiKgQghoLAKaEdAqBFQOAfUQ0DACahHQRARUCAGNRUAzAlqFgMohoB4CGkZALQKaiIAKIaCxCGhGQKsQUDkE1ENAwwioRUATEVAhBDQWAc0IaBUCKoeAeghoGAG1CGgiAiqEgMYioBkBrUJA5RBQDwENI6AWAU1EQIUQ0FgENCOgVQioHALqIaBhBNQioIkIqBACGouAZgS0CgGVQ0A9BDSMgFoENBEBFUJAYxHQjIBWIaByCKiHgIYRUIuAJiKgQghoLAKaEdAqBFQOAfUQ0DACahHQRARUCAGNRUAzAlqFgMohoB4CGkZALQKaiIAKIaCxCGhGQKsQUDkE1ENAwwioRUATEVAhBDQWAc0IaBUCKoeAeghoGAG1CGgiAiqEgMYioBkBrUJA5RBQDwENI6AWAU1EQIUQ0FgENCOgVQioHALqIaBhBNQioIkIqBACGouAZgS0CgGVQ0A9BDSMgFoENBEBFUJAYxHQjIBWIaByCKiHgIYRUIuAJiKgQghoLAKaEdAqBDTKneddk+fdL5UPIqAeAhpGQC0CmmgoBXTursbslOcLt3iudBgB9RDQMAJqEdBEQymgR43Z85jdat8vOKp0GAH1ENAwAmoR0ERDKaAb3pHnNqD3fqB0GAH1ENAwAmoR0ERDKaC2m9vV/rtmUukwAuohoGEE1CKgiYZSQLeu/Z3NqH0/eO3SYQTUQ0DDCKhFQBMNpYCe8J3ufFP7T/kTpcMIqIeAhhFQi4AmGkoBfXXqxvtPOWAT03Vb6TAC6iGgYQTUIqCJhlJA84fWMTVTLisfRUA9BDSMgFoENNGQCmi+6Mbzzr12TsUgAuohoGEE1CKgiYZWQBuOLb2UgHoIaBgBtQhooqEY0DmblV5MQD0ENIyAWgQ00dAI6DXjW4wz5TeagHoIaBgBtQhooqER0GfNqtN7bDS1q3QwAfUQ0DACahHQREMjoPnac1vX3l86loB6CGgYAbUIaKIhEtDLvbULS8cSUA8BDSOgFgFNNEQC2gkC6iGgYQTUIqCJhmRADyy9lIB6CGgYAbUIaKIhFdCXLjn56zVfmlI6ioB6CGgYAbUIaKKhFNBsgmkoHUZAPQQ0jIBaBDTRUAro9KVP/8m+Dz546MybS4cRUA8BDSOgFgFNNJQCOvG7+bwZeb7oky+XDiOgHgIaRkAtAppoKAV0yj15/p7X8/zST5UOI6AeAhpGQC0CmmgoBXT32/P8axfk+UlLlQ4joB4CGkZALQKaaCgF9I533ZrfN3a3PcZOKx1GQD0ENIyAWgQ00VAKaH5R7V/v8caMubR0FAH1ENAwAmoR0ERDKqCFx37zePkAAuohoGEE1CKgiYZIQK/z1sr/ERNQDwENI6AWAU00RAK6fclabwTUQ0DDCKhFQBMNkYBOOOCYE5uOOZBH4QsENAUBtQhooiESUOMrHUtAPQQ0jIBaBDTREAnoe82bDvl6w5c/NqZ0LAH1ENAwAmoR0ERDJKD5H3Z+63dfb65sVzqUgHoIaBgBtQhooqES0Dx/cL9Vjn2xvnhH6UAC6iGgYQTUIqCJhk5A8/xfX1v5sCerhxFQDwENI6AWAU00lAKa56+csvq+D1YNIqAeAhpGQC0CmmhoBTTP516wzk7Xl//dEVAPAQ0joBYBTTTUApr/cWdj3lU6goB6CGgYAbUIaKKhFdBFV29pzPJHPV86iIB6CGgYAbUIaKKhFNB5F61rzCpnvFYxjIB6CGgYAbUIaKKhE9BXT1/FmLV/OK9yIAH1ENAwAmoR0ERDJaDPHLmsMZv/ov639ofSoQTUQ0DDCKhFQBMNkYAeMN6Y7W7sbqztUDqWgHoIaBgBtQhooiESUPvQ0S8arjhrSulYAuohoGEE1CKgiYZIQLs222WPpl027yodS0A9BDSMgFoENNEQCeg23toHS8cSUA8BDSOgFgFNNEQCepK3NrN0LAH1ENAwAmoR0ERDJKCdIKAeAhpGQC0CmoiACiGgsQhoRkCrEFA5BNRDQMMIqEVAExFQIQQ0FgHNCGgVAiqHgHoIaBgBtQhoIgIqhIDGIqAZAa1CQOUQUA8BDSOgFgFNRECFENBYBDQjoFUIqBwC6iGgYQTUIqCJCKgQAhqLgGYEtAoBlUNAPQQ0jIBaBDQRARVCQGMR0IyAViGgcgioh4CGEVCLgCYioEIIaCwCmhHQKgRUDgH1ENAwAmoR0EQEVAgBjUVAMwJahYDKIaAeAhpGQC0CmoiACiGgsQhoRkCrEFA5BNRDQMMIqEVAExFQIQQ0FgHNCGgVAiqHgHoIaBgBtQhoIgIqhIDGIqAZAa1CQOUQUA8BDSOgFgFNRECFENBYBDQjoFUIqBwC6iGgYQTUIqCJCKgQAhqLgGYEtAoBlUNAPQQ0jIBaBDQRARVCQGMR0IyAViGgcgioh4CGEVCLgCYioEIIaCwCmhHQKgRUDgH1ENAwAmoR0EQEVAgBjUVAMwJahYDKIaAeAhpGQC0CmoiACiGgsQhoRkCrEFA5BNRDQMMIqEVAExFQIQQ0FgHNCGgVAiqHgHoIaBgBtQhoIgIqhIDGIqAZAa1CQOUQUA8BDSOgFgFNRECFENBYBDQjoFUIqBwC6iGgYQTUIqCJCKgQAhqLgGYEtAoBlUNAPQQ0jIBaBDQRARVCQGMR0IyAViGgcgioh4CGEVCLgCYioEIIaCwCmhHQKgRUDgH1ENAwAmoR0EQEVAgBjUVAMwJahYDKIaAeAhpGQC0CmoiACiGgsQhoRkCrEFA5BNRDQMMIqEVAExFQIQQ0FgHNCGgVAiqHgHoIaBgBtQhoIgIqhIDGIqAZAa1CQOUQUA8BDSOgFgFNRECFENBYBDQjoFUIqBwC6iGgYQTUIqCJCKgQAhqLgGYEtAoBlUNAPQQ0jIBaBDQRARVCQGMR0IyAViGgcgioh4CGEVCLgCYioEIIaCwCmhHQKgRUDgH1ENAwAmoR0EQEVAgBjUVAMwJahYDKIaAeAhpGQC0CmoiACiGgsQhoRkCrEFA5BNRDQMMIqEVAExFQIQQ0FgHNCGgVAiqHgHoIaBgBtQhoIgIqhIDGIqAZAa1CQOUQUA8BDSOgFgFNRECFENBYBDQjoFUIqBwC6iGgYQTUIqCJCKgQAhqLgGYEtAoBlUNAPQQ0jIBaBDQRARVCQGMR0IyAViGgcgioh4CGEVCLgCYioEIIaCwCmhHQKgRUDgH1ENAwAmoR0EQEVAgBjUVAMwJahYDKIaAeAhpGQC0CmoiACiGgsQhoRkCrEFA5BNRDQMMIqEVAE4kHdNu3brDN49KTeAioh4CGEVCLgCYSD+gyxhy2UHoSDwH1ENAwAmoR0ETiAX2veXO3W7tberqcgPZCQMMIqEVAE4kH9Pej129ZGy09XU5AeyGgYQTUIqCJ5B9EumyJm3qWu7vEpyOgvRDQMAJqEdBE4gFdsCBb/ZRH5y2omf/0bzQe9CegHgIaRkAtAppIumjdKxqP8HQWAfUQ0DACahHQROJF25+ASiGgKQioRUATiRftBrP0xjvtWvjojFUJaD8ioCkIqEVAE4kXbXbXr9zKawS0HxHQFATUIqCJ5Iu29h9bVngaUz8ioCkIqEVAE8kH9K5XWlZ+Lj4dAe2FgIYRUIuAJtL4mbr7iatvVpimiYB6CGgYAbUIaCKFgF6xkjGrF0uHyv/rywloLwQ0jIBaBDSRfECPsM9eGl+8Hv6OMfeKT0dAeyGgYQTUIqCJxAP6l1Fm5Z0PGvdSsbLr9tLT5QS0FwIaRkAtAppIPKB7jzprXp5PerpYOX/089LzEdBeCGgYAbUIaCLxgK5/rP066cli5UbzM+n5CGgvBDSMgFoENJF4QCfcb79OmlWsXGlOk56PgPZCQMMIqEVAE4kHdNos+3VC8TX/sjlVej4C2gsBDSOgFgFNJB7Q3S/K7fuAzrLLzyxnfio9HwHthYCGEVCLgCaSfzORaS/n+Twzq7b44pZm1LNV49MRUA8BDSOgFgFNJB7Q7k3XvmbBK2ZW979PW8WYnaSnywloLwQ0jIBaBDSR/BPpH55oxq5gVpton08/8THx6QhoLwQ0jIBaBDSRwks5b5jcfDfl5W6Rn42A9kJAwwioRUATabyZyJOHr1yr59i1TvmPwmQEtBcCGkZALQKaSCOgNbMfe0rtD0xAPQQ0jIBaBDSRUkA1EVAPAQ0joBYBTaQc0G8ozEFAPQQ0jIBaBDSRckBHKcxBQD0ENIyAWgQ0kW5AZ/Ghcv2IgKYgoBYBTSRVtAVrrbaYVZc2pltovhYE1ENAwwioRUATiZ0SzjBB86Xmcwioh4CGEVCLgCYSC+hMM2G9DWrWN2aS/f6OVceY9bZYf47UfA4B9RDQMAJqEdBEYgHNzDPF9z+YFf9Z3/L8wdNekJqtFQH1ENAwAmoR0ERiAX2hsefPtfyTO26reVLTtSCgHgIaRkAtAppI7mHxxr+0NVd2v/bs3uAzPIjUfwhoCgJqEdBE4s8rGv/RlpWTzQ3S8xHQXghoGAG1CGgi8YC+5ZCWlXP5TKR+REBTEFCLgCYSD+h+H2pZ2dt8T3o+AtoLAQ0joBYBTSQe0Pve9GLP8oPLmKul5yOgvRDQMAJqEdBE8q+t/MQOCxpLj6xmuv4hPh8B9RHQMAJqEdBE8gH9+9i1Ln1iYffTN+0z2piPi09HQHshoGEE1CKgiRTe3eO79u3olyxeyDlF4QSUgPoIaBgBtQhoIoWAdn9vQuOF8Js/Ij8bAe2FgIYRUIuAJlJ5O7tnztphwzW3OOg6hWfR5wS0FwIaRkAtApqIj/QQQkBjEdCMgFYZqQG9dqH8HATUQ0DDCKhFQBPpBnThKIV3EyGgHgIaRkAtAppIN6CPGM5A+w8BTUFALQKaSCGgDx+x28b2LZU3eOcqY/hIj35EQFMQUIuAJpIP6LFjWj/SY0H1FVIRUA8BDSOgFgFNJB7Qm2w2J/Z8sBy/A+0/BDQFAbUIaCLxgO5gzGf/rvME0AYC6iGgYQTUIqCJxAP6dnOg9BS9EFAPAQ0joBYBTST/jvTm79JT9EJAPQQ0jIBaBDSReEBXHaXwzCUPAfUQ0DACahHQROIB/aZ52K0smiU9XU5AeyGgYQTUIqCJxAM6Z/OvupXXNJ63T0A9BDSMgFoENJF80Z5d53c9yy8Q0H40bAO6x14KNm0N6Brp+xvfGtBdU/f2kdaATki/de1Mbg3otn2/3o6tAV1a7va1M2IC2n3cUXuN2/OowrcP2pKA9qNhGtBljJKDmzNe0C+763qlub8398fuVm/u7bmu/thdW/c053lvZ9d7R/N6T8jcrgpLqD41sj3xor3b/3NLT5cT0F6GXEBvOEnHzKebM845uz/2d1XPn+Dm/tjdH3p29/P+2F07P+qZ5q+dXfGOniteLnLDKlwnfTfsI/GinUlApQzTgAJDh3jR/m4+edWf7i785frjCGg/IqDAABMvWveyt7iVVwhoPyKgwACTL9r+97nl1zcQn46A9kJAATEap4TdT1x9s8I0TQTUQ0ABMQoBvWKl5nMyDlX510dAPQQUECMf0CPsg+/ji2dt3THmXvHpCGgvBBQQIx7Qv4wyK+980LiXipVdt5eeLiegvRBQQIx4QPcedda8PJ9Uf9Ly+aOfl56PgPZCQAEx4gFd/1j7ddKTxcqN5mfS8xHQXggoIEY8oBPut18nzSpWrjSnSc9HQHshoIAY8YBOm2W/Tii+5l82p0rPR0B7IaCAGPGA7n5R7Ut31yy7/Mxy5qfS8xHQXggoIEY8oDdMeznP55lZtcUXtzSjnq0an46AeggoIEb+tfCbrn3NglfMrO5/n7aKMTtJT5cT0F4IKCBG/on0D080Y1cwq020z6ef+Jj4dAS0FwIKiFF4KecNk5tvBrrcLdWj0xFQDwEFxGi8mciTh69cq+fYtU75j8JkBLQXAgqI0QhozezHnlL7ECgC6iGggBilgD72ss48FgH1EFBAjFxA585tWdnvuLkLLLHZWhBQDwEFxMgF9LKx79r7i81PKtyv/ijS+DfEpnMIqIeAAmLkAvp5s9QXj72msdIIqLlJbDqHgHoIKCBGLqDvMDe4lf3MkpMnL2fMsWLTOQTUQ0ABMWIBfda8v2Vtv53n177O/sQHpaZrQUA9BBQQIxbQG7z3Ddmv/jZ2t0+cLzWfQ0A9BBQQIxbQy80TLWv7XVx8e8XcLzWfQ0A9BBQQIxbQc5bobln7/p+Lb90Tfyc1n0NAPQQUECMW0GPfHNq6+kVS8zkE1ENAATFiAT1jamjrsidJzecQUA8BBcSIBfSiyYGNc80ZUvM5BNRDQAExYgH9TdfcxTfeZH4sNZ9DQD0EFBAjFtDnQq86+oa5UWo+h4B6CCggRu6VSGt+dbFNr60wfo7YfD0IqIeAAmLkAnro0i/13nSU+YDYdA4B9RBQQIxcQB8xH+/2t/xmlPmR2HQOAfUQUECM4Bsqf8R83XsX+ssmmNUVXslJQH0EFBAjGNAnlzX/9deetQf2NsZcLjebQ0A9BBQQI/mRHj/rMmbG8dfd9cifrj56q9qyOVBwMoeAeggoIEb0M5EuG21a7RV4ZqgAAuohoIAY2Q+Vu3V9l89Jp3dXX6E/EFAPAQXECH8q54JLdhhn69m1yXGLPalJCgH1EFBAjPzHGs955KYb/qpWz5yA9kJAATFKnwuviYB6CCgghoAKIaDA8EdAhRBQYPgjoEIIKDD8EVAhBBQY/gioEAIKDH8EVAgBBYY/AiqEgALDHwEVQkCB4Y+ACiGgwPBHQIUQUGD4I6BCCCgw/BFQIQQUGP4IqBACCgx/BFQIAQWGPwIqhIACwx8BFUJAgeGPgAohoMDwR0CFEFBg+COgQggoMPwRUCEEFBj+CKgQAgoMfwRUCAEFhj8CKoSAAsMfARVCQIHhj4AKIaDA8EdAhRBQYPgjoEIIKDD8EVAhBBQY/gioEAIKDH8EVAgBBYY/AiqEgALDHwEVQkCB4Y+ACiGgwPBHQIUQUGD4I6BCCCgw/BFQIQQUGP4IqBACCgx/BFQIAQWGPwIqhIACwx8BFUJAgeGPgAohoMDwR0CFEFBg+COgQggoMPwRUCEEFBj+CKgQAgoMfwRUCAEFhj8CKoSAAsMfARVCQGMdMr3ufU80t1y18fTp732gufZ/m04flDbNmrfwgffKznR0c6IFu8tOFPTue5rT37rZAEzf8AXx+2HfEFAhBDTWONNwSXPLXnbtzObaQWaQ+mLzFp4pPNEqzYkeF54o7MTm9F8dkOnruhaJ3xH7hIAKIaCxxprv/aBmM3Nxc8ue5rPbmDOaa18we/1gENrLHNS8hWeYbQQnOsms3JxolpksOFHYduaE5vSHm13Vp2/oMgRUCgH1DMGAXm/n/WBrQL+1a2tAD0n6axNycGtAdxWc6IrWgK4kOFHY3q0BPUB9+gYCKoeAegioDgKqiYDKIaAeAqqDgGoioHIIqIeA6iCgmgioHALqIaA6CKgmAiqHgHoIqA4CqomAyiGgHgKqg4BqIqByCKiHgOogoJoIqBwC6iGgOgioJgIqh4B6CKgOAqqJgMohoB4CqoOAaiKgcgioh4DqIKCaCKgcAuohoDoIqCYCKoeAegioDgKqiYDKIaAeAqqDgGoioHIIqIeA6iCgmgioHALqIaA6CKgmAiqHgHoIqA4CqomAyiGgHgKqg4BqIqByCKiHgOogoJoIqBwC6iGgOgioJgIqh4B6CKgOAqqJgMohoB4CqoOAaiKgcgioh4DqIKCaCKicK82GPxh4WzcD+imxKfZqBvS/ykad2Kzimyt3GBx6QDOgm9VW3ktA2yGgmgionKvM4HCOvTH7ik5R/JOdWTVqVTvqoT7tMDj0o3bjpY2VC8WPHwEtR0AzAirpuW2nDwYffNTemN9tLjjFVjfZKf62VfmozU6xo+bv0YcdBoe+9yq78akPFCvbPiF+/AhoOQKaEVCgHQJajoBmBBRoh4CWI6AZAQXaIaDlCGhGQIF2CGg5ApoRUKAdAlqOgGYEFGiHgJYjoBkBBdohoOUIaEZAgXYIaDkCmhFQoB0CWo6AZgQUaIeAliOgGQEF2iGg5QhoRkCBdghoOQKaEVCgHQJajoBmBBRoh4CWI6AZAQXaIaDlCGhGQIF2CGg5ApoRUKAdAlqOgGYEFGiHgJYjoBkBBdohoOUIaEZAgXYIaDkCmhFQoB0CWo6AZgQUaIeAliOgGQEF2iGg5QhoRkCBdghoOQKaEVCgHQJajoBmBBRoh4CWI6AZAQXaIaDlCGhGQIF2CGg5ApoRUKAdAlqOgGYEFGiHgJYjoBkBBdohoOUIaEZAgXYIaDkCmhFQoB0CWo6AZgQUaIeAliOgGQEF2iGg5QhoRkCBdghoOQKaEVCgHQJajoBmBBRoh4CWI6AZAQXaIaDlCGhGQIF2CGg5ApoRUKAdAlqOgGYEFGiHgJYjoBkBBdohoOUIaEZAgXYIaDkCmhFQoB0CWo6AZgQUaIeAliOgGQEF2iGg5QhoRkCBdghoOQKaEVCgHQJajoBmBBRoh4CWI6AZAQXaIaDlCGhGQIF2CGg5ApoRUKAdAlqOgGYEFGiHgJYjoBkBBdohoOUIaEZAgXYIaDkCmhFQoB0CWo6AZgQUaIeAliOgGQEF2iGg5QhoRkCBdghoOQKaEVCgHQJajoBmBBRoh4CWI6AZAQXaIaDlCGhGQIF2CGg5ApoRUKAdAlqOgGYEFGiHgJYjoBkBBdohoOUIaEZAgXYIaDkCmhFQoB0CWo6AZgQUaIeAliOgGQEF2iGg5QhoRkCBdghoOQKaEVCgHQJajoBmBBRoh4CWI6AZAQXaIaDlCGhGQIF2CGg5ApoRUKAdAlqOgGYEFGiHgJYjoBkBBdohoOUIaEZAgXYIaDkCmhFQoB0CWo6AZgQUaIeAliOgGQEF2iGg5QhoRkCBdghoOQKaEVCgHQJajoBmBBRoh4CWI6AZAQXaIaDlCGhGQIF2CGg5ApoRUKAdAlqOgGYEFGiHgJYjoBkBBdohoOUIaEZAJS0456SOPWqvOPfsnvUfFnu6rfMdJTr5cTvv7DP6bYc/Kv4gf4y67g3Fda/wtp05R/z4EdByBDQjoJJ+Yzq3h73iz1o2PGA3rBexp0Sfs/Ne0I87fMjucJ2oq77JXvXFXhsvFT9+BLQcAc0IqKQrzSp7dWZL8xF7xUvM6o0Ny5m77IY1zA4d7inR5mYfO+/3zBr9tMNlzT12h9PMjh1fdTeztL3qv82SLRunmv8RP34EtBwBzQiopCvNFh0ejWOaAf1gY8MazYBe3N8HvtwRzYDu3E87nNYM6KUdX/XqZkAnt2zcnoC2Q0A1EVA5BNQhoGoIqCYCKoeAOgRUDQHVREDlEFCHgKohoJoIqBwC6hBQNQRUEwGVQ0AdAqqGgGoioHIIqENA1RBQTQRUDgF1CKgaAqqJgMohoA4BVUNANRFQOQTUIaBqCKgmAiqHgDoEVA0B1URA5RBQh4CqIaCaCKgcAuoQUDUEVBMBlUNAHQKqhoBqIqByCKhDQNUQUE0EVA4BdQioGgKqiYDKIaAOAVVDQDURUDkE1CGgagioJgIqh4A6BFQNAdVEQOUQUIeAqiGgmgioHALqEFA1BFQTAZVDQB0CqoaAaiKgcgioQ0DVEFBNBFQOAXUIqBoCqomAyiGgDgFVQ0A1EVA5BNQhoGoIqCYCKoeAOgRUDQHVREDlEFCHgKohoJoIqBwC6hBQNQRUEwGVQ0AdAqqGgGoioHIIqENA1RBQTQRUDgF1CKgaAqqJgMohoA4BVUNANRFQOQTUIaBqCKgmAiqHgDoEVA0B1URA5RBQh4CqIaCaCKgcAuoQUDUEVBMBlUNAHQKqhoBqIqByCKhDQNUQUE0EVA4BdQioGgKqiYDKIaAOAVVDQDURUDkE1CGgagioJgIqh4A6BFQNAdVEQOUQUIeAqiGgmgioHALqEFA1BFQTAZVDQB0CqoaAaiKgcgioQ0DVEFBNBFQOAXUIqBoCqomAyiGgDgFVQ0A1EVA5BNQhoGoIqCYCKoeAOgRUDQHVREDlEFCHgKohoJoIqBwC6hBQNQRUEwGVQ0AdAqqGgGoioHIIqENA1RBQTQRUDgF1CKgaAqqJgMohoA4BVUNANRFQOQTUIaBqCKgmAiqHgDoEVA0B1URA5RBQh4CqIaCaCKgcAuoQUDUEVBMBlUNAHQKqhoBqIqByCKhDQNUQUE0EVA4BdQioGgKqiYDKIaAOAVVDQDURUDkE1CGgagioUqNnvgAAEs9JREFUJgIqh4A6BFQNAdVEQOUQUIeAqiGgmgioHALqEFA1BFQTAZVDQB0CqoaAaiKgcgioQ0DVEFBNBFQOAXUIqBoCqomAyiGgDgFVQ0A1EVA5BNQhoGoIqCYCKoeAOgRUDQHVREDlEFCHgKohoJoIqBwC6hBQNQRUEwGVQ0AdAqqGgGoioHIIqENA1RBQTQRUDgF1CKgaAqqJgMohoA4BVUNANRFQOQTUIaBqCKgmAiqHgDoEVA0B1URA5RBQh4CqIaCaCKgcAuoQUDUEVBMBlUNAHQKqhoBqIqByCKhDQNUQUE0EVA4BdQioGgKqiYDKIaAOAVVDQDURUDkE1CGgagioJgIqh4A6BFQNAdVEQOUQUIeAqiGgmgioHALqEFA1BFQTAZVDQB0CqoaAaiKgcgioQ0DVEFBNBFQOAXUIqBoCqomAyiGgDgFVQ0A1EVA5BNQhoGoIqCYCKoeAOgRUDQHVREBj3HneNXne/VLFKALqEFA1BFQTAe3c3F2N2SnPF27xXPk4AuoQUDUEVBMB7dxRY/Y8Zrfa9wuOKh9HQB0CqoaAaiKgndvwjjy3Ab33A+XjCKhDQNUQUE0EtHO2m9vV/rtmUvk4AuoQUDUEVBMB7dzWtb+yGbXvB69dPo6AOgRUDQHVREA7d8J3uvNN8/xi84nycQTUIaBqCKgmAtq5V6duvP+UAzYxXbeVjyOgDgFVQ0A1EdAID61jaqZcVjGMgDoEVA0B1URAYyy68bxzr51TNYqAOgRUDQHVREATHFt+MQF1CKgaAqqJgMabs1n55QTUIaBqCKgmAtqJa8a3GGcqbjMBdQioGgKqiYB24lmz6vQeG03tKh9NQB0CqoaAaiKgHVl7buva+8sHE1CHgKohoJoIaEcu99YuLB9MQB0CqoaAaiKgcgioQ0DVEFBNBDTBgeUXE1CHgKohoJoIaISXLjn56zVfmlI+jIA6BFQNAdVEQDuXTTAN5eMIqENA1RBQTQS0c9OXPv0n+z744KEzby4fR0AdAqqGgGoioJ2b+N183ow8X/TJl8vHEVCHgKohoJoIaOem1Frwntfz/NJPlY8joA4BVUNANRHQzu1+e55/7YI8P2mp8nEE1CGgagioJgLauTvedWt+39jd9hg7rXwcAXUIqBoCqomARrio9o/3eGPGXFo+jIA6BFQNAdVEQGM99pvHK0YQUIeAqiGgmghogpvKLyagDgFVQ0A1EdAEO5RfTEAdAqqGgGoioBGeOvPggw466Asfn9BdOoyAOgRUDQHVREA7d1PPSznL/+4IqENA1RBQTQS0c5uMPTK7u8AZaF8RUDUEVBMB7dySFZ/G2URAHQKqhoBqIqCdW+tHfRtHQB0CqoaAaiKgnfv1Do0f3XcvH0dAHQKqhoBqIqARzj3glttuu+2P104tH0ZAHQKqhoBqIqCde3pz3lC5UwRUDQHVREA7t6OZuu9hhx32lX0nlo8joA4BVUNANRHQzk3ceUF9YcfycQTUIaBqCKgmAtq55X/cWLizfBwBdQioGgKqiYB27vDDGgs/KR9HQB0CqoaAaiKgnVuw5y31hRnl4wioQ0DVEFBNBLRz01cxq02bNm3qZB6F7zMCqoaAaiKgndvJjJ+y4oorThlPQPuMgKohoJoIaOfO3r/+SqTuLcrHEVCHgKohoJoIaOf+fnVj4fTycQTUIaBqCKgmAhrjzvOuqZ2AvlQxioA6BFQNAdVEQDs3d1djdsrzhVs8Vz6OgDoEVA0B1URAO3fUmD2P2a32/YKjyscRUIeAqiGgmgho5za8I89tQO/9QPk4AuoQUDUEVBMB7Zzt5na1/66ZVD6OgDoEVA0B1URAO7f1ovqLkA5eu3wcAXUIqBoCqomAdu6E73Tnm+b5xeYT5eMIqENA1RBQTQS0c69O3Xj/KQdsYrpuKx9HQB0CqoaAaiKgER5ax74d/ZTLKoYRUIeAqiGgmghoR35734v2ZZyLbjzv3GvnVA0moA4BVUNANRHQjpjV33dj/sgT/3p8Vh8GE1CHgKohoJoIaEfMX2tfjny/mXFmHwYTUIeAqiGgmghoR8yr9ut/TOWP7xYBdQioGgKqiYB2ZOn6t2X6NJiAOgRUDQHVREA7slL9W+MlSDPLBxNQh4CqIaCaCGhHlqh/awT0Q+WDCahDQNUQUE0EtCPmS4dY4+yXL+wyrnwwAXUIqBoCqomAdsT4ygcTUIeAqiGgmghoR5Y99JQzmk4+dOnywQTUIaBqCKgmAtqRj3hrHy4fTEAdAqqGgGoioB25xFu7qHwwAXUIqBoCqomAyiGgDgFVQ0A1EVA5BNQhoGoIqCYCKoeAOgRUDQHVREDlEFCHgKohoJoIqBwC6hBQNQRUEwGVQ0AdAqqGgGoioHIIqENA1RBQTQRUDgF1CKgaAqqJgMohoA4BVUNANRFQOQTUIaBqCKgmAiqHgDoEVA0B1URA5RBQh4CqIaCaCKgcAuoQUDUEVBMBlUNAHQKqhoBqIqByCKhDQNUQUE0EVA4BdQioGgKqiYDKIaAOAVVDQDURUDkE1CGgagioJgIqh4A6BFQNAdVEQOUQUIeAqiGgmgioHALqEFA1BFQTAZVDQB0CqoaAaiKgcgioQ0DVEFBNBFQOAXUIqBoCqomAyiGgDgFVQ0A1EVA5BNQhoGoIqCYCKoeAOgRUDQHVREDlEFCHgKohoJoIqBwC6hBQNQRUEwGVQ0AdAqqGgGoioHIIqENA1RBQTQRUDgF1CKgaAqqJgMohoA4BVUNANRFQOQTUIaBqCKgmAiqHgDoEVA0B1URA5RBQh4CqIaCaCKgcAuoQUDUEVBMBlUNAHQKqhoBqIqByCKhDQNUQUE0EVA4BdQioGgKqiYDKIaAOAVVDQDURUDkE1CGgagioJgIqh4A6BFQNAdVEQOUQUIeAqiGgmgioHALqEFA1BFQTAZVDQB0CqoaAaiKgcgioQ0DVEFBNBFQOAXUIqBoCqomAyiGgDgFVQ0A1EVA5BNQhoGoIqCYCKoeAOgRUDQHVREDlEFCHgKohoJoIqBwC6hBQNQRUEwGVQ0AdAqqGgGoioHIIqENA1RBQTQRUDgF1CKgaAqqJgMohoA4BVUNANRFQOQTUIaBqCKgmAiqHgDoEVA0B1URA5RBQh4CqIaCaCKgcAuoQUDUEVBMBlUNAHQKqhoBqIqByCKhDQNUQUE0EVA4BdQioGgKqiYDKIaAOAVVDQDURUDkE1CGgagioJgIqh4A6BFQNAdVEQOUQUIeAqiGgmgioHALqEFA1BFQTAZVDQB0CqoaAaiKgcgioQ0DVEFBNBFQOAXUIqBoCqomAyiGgDgFVQ0A1EVA5BNQhoGoIqCYCKoeAOgRUDQHVREDlEFCHgKohoJoIqBwC6hBQNQRUEwGVQ0AdAqqGgGoioHIIqENA1RBQTQRUDgF1CKgaAqqJgMohoA4BVUNANRFQOQTUIaBqCKgmAiqHgDoEVA0B1URA5RBQh4CqIaCaCKgcAuoQUDUEVBMBlUNAHQKqhoBqIqByCKhDQNUQUE0EVA4BdQioGgKqiYDKIaAOAVVDQDURUDkE1CGgagioJgIqh4A6BFQNAdVEQOUQUIeAqiGgmgioHALqEFA1BFQTAZVDQB0CqoaAaiKgcgioQ0DVEFBNBFQOAXUIqBoCqomAyiGgDgFVQ0A1EVA5BNQhoGoIqCYCKoeAOgRUDQHVREDlXGmWWrMzb2kGdOnGhvHNgL6twz0lWqkZ0GX7aYfjmwHt/A/y9mZAx7RsnKQS0DXsVMu0BvTNy7YGdEo//e30qymtAe2v4xcytTWgY6rH97PlWwO6gvr0DYaAivlTl+nYl+wVb3Tr45+yG7bpfEepjrTz/qr/9jf+33aHM6Kuu4696uvL+BuvEz9+U5tT/b655at27efNtRPj/zZkndS8hT8Xnmjz5kSvLCU8U9AlzenPGojZG3r+JzLAhmFA88f+3Km/LCiu+EjPhieL9dkd7yjVXfX/rz7Ybzus/0Fei7ruy8V1n/a2PSx/+F5sTPVIz5aFd/35zw/0rHXfk/h3IuSe7p6b+IDsTK/2TPRv2YmC7ndH4t4BmL7hBeF7YV8Nx4ACgAoCCgCRCCgARCKgABCJgAJAJAIKAJEIKABEIqAAEImAAkAkAgoAkQgoAEQioAAQiYACQCQCCgCRCCgARCKgABCJgAJAJAIKAJEIKABEIqAAEImAAkAkAgoAkQgoAEQioAAQiYACQCQCCgCRCCgARCKgABCJgAJAJAIKAJEIKABEIqAAEImAAkAkAgoAkQgoAEQioAAQiYACQCQCCgCRCCgARCKgABCJgAJAJAIKAJEIKABEIqAAEImAAkAkAgoAkQgoAEQioBjSFgz0DcCIRkAxZL3w+1O3XmugbwRGNAKKQe8ec21o8wWmZjXl2wK0IqAY9D5ntgtf8MyEvgX0mUX9eGsAh4BisHtpSWMeDF+0Xp8CeqRZt/Gr0kcPf7G/bhWQE1AMfqfXflI/MHzRBn0K6LrG3F8s7N1lnuq3mwUQUAx6C1b7/AQz4aXgZX0L6IVv3rO7WFjNmDf674YBBBSD3U/H/vsgY2YGL+tbQHusa5bqj1sENBFQDG7dm34mf7TLrBp8wmdrQLur97URD9qjfxFQDG43m/vyfBdjfu5tve+zKy+x9uf/uH6ziK9ctdf0fOHZ6y45Zcfba6v/2vetS2127LzG4DlXfmphsTDdrKN2uzEiEFAMbjt/qPblVmO2bNn2j09O3u6QXVbueR7oVVNrS9Pm7WG6at/H/Sa/9y3F0sb2F56zDtpigjH2/HX2OZPMUh+u4YEk9BcCikHt4a7/q33t3syYvzQ3dZ8z9sMv1L7PP3/FRkCf/uOPjFl5uxnZ7Cc/bsyKV0756sPzb13dmONrlz1x+jfGFgG9czlTN3peeCqgYwQUg9oB7yp+t3mFMfs0N33PrNn4heg/l2n+CN+9lDGfsyMXvbN2DnqD3XRP7aS0fuH69TPQPJ9m1lW62RghCCgGs+eX/HHxfcHqZtzT9U3PTDCXNC92DyKtaca/Wiycbcze9U2bmVH1Jy1tT0AhhIBiMDvmLa++UTjFmKPqm84y5onmxS6g6zZPN39rzLH1pX2MmVUs7EpAIYSAYhB7Y4pxVpxbbNvBjF3YvDwQ0D/1BPQQAgppBBSD2PlL3Hhbw37GXFRs29As2fOUz0BA7ySg0ENAMXgtekfPI0f5/cbUH09a05inmxvfQUAxoAgoBq9rzI1uZboxN9vvWxhzU3PbqgQUA4qAYvDaeoWFbuVsYz5qvx/kntH0/BgCigFFQDFo3WX2bVl7tst0/a32/TpjRj9a33SwMas2Ll3HTK0v/MmYY+pLtYD+o1j4qDHzi4Vp5u3iNxojCgHFoLWL+WXr6nuN2TOvvypptYfswonT1jNLNy5cySxXX/itMV+uLx3SfPXSDGOeLRY2MONfzHNeiIR+Q0AxSM05wZgTW94G9LWdjOm6alGePzzFmEmf+MHMd231/BbGPF5c+MwoY560C92nGrNt/Qf2WkAvsg87zV7VmOK1Sfkexqz75Q99TPfPgeGMgGJwOqarePLnho3VX00cVayP+Wue/2Pv4rLPzLMv0jSjvpEfN7q4bImL8zXr1yp+xj/EXrjRz+uXjdq9tuU++3L4tV8YwD8VhhkCiiHoH78+59Tf1c4u58wreRfQ+fMW+yy5Fy8++aqXJW8YRhgCCgCRCCgARCKgABCJgAJAJAIKAJEIKABEIqAAEImAAkAkAgoAkQgoAEQioAAQiYACQCQCCgCRCCgARCKgABCJgAJAJAIKAJEIKABEIqAAEImAAkAkAgoAkQgoAEQioAAQiYACQCQCCgCRCCgARCKgABCJgAJAJAIKAJEIKABEIqAAEImAAkAkAgoAkQgoAEQioAAQiYACQCQCCgCRCCgARCKgABCJgAJAJAIKAJEIKABEIqAAEImAAkAkAgoAkQgoAEQioAAQiYACQCQCCgCRCCgARCKgABCJgAJAJAIKAJEIKABEIqAAEImAAkAkAgoAkQgoAEQioAAQiYACQCQCCgCRCCgARCKgABCJgAJAJAIKAJEIKABEIqAAEImAAkAkAgoAkQgoAEQioAAQiYACQCQCCgCRCCgARCKgABCJgAJAJAIKAJEIKABEIqAAEImAAkAkAgoAkQgoAEQioAAQiYACQCQCCgCRCCgARCKgABCJgAJAJAIKAJEIKABEIqAAEImAAkAkAgoAkQgoAEQioAAQiYACQCQCCgCRCCgARCKgABCJgAJAJAIKAJEIKABEIqAAEImAAkAkAgoAkQgoAEQioAAQiYACQCQCCgCRCCgARCKgABCJgAJAJAIKAJEIKABEIqAAEImAAkAkAgoAkQgoAEQioAAQiYACQCQCCgCRCCgARCKgABCJgAJAJAIKAJEIKABE+v/7HXFq+JjUfAAAAABJRU5ErkJggg==)
# Frequencia cruzada.
addmargins(margin.table(UCBAdmissions, 1:2))
## Gender
## Admit Male Female Sum
## Admitted 1198 557 1755
## Rejected 1493 1278 2771
## Sum 2691 1835 4526
# Transforma em tabela.
da <- as.data.frame(UCBAdmissions)
da
## Admit Gender Dept Freq
## 1 Admitted Male A 512
## 2 Rejected Male A 313
## 3 Admitted Female A 89
## 4 Rejected Female A 19
## 5 Admitted Male B 353
## 6 Rejected Male B 207
## 7 Admitted Female B 17
## 8 Rejected Female B 8
## 9 Admitted Male C 120
## 10 Rejected Male C 205
## 11 Admitted Female C 202
## 12 Rejected Female C 391
## 13 Admitted Male D 138
## 14 Rejected Male D 279
## 15 Admitted Female D 131
## 16 Rejected Female D 244
## 17 Admitted Male E 53
## 18 Rejected Male E 138
## 19 Admitted Female E 94
## 20 Rejected Female E 299
## 21 Admitted Male F 22
## 22 Rejected Male F 351
## 23 Admitted Female F 24
## 24 Rejected Female F 317
# Total de casos.
tot <- sum(da$Freq)
tot
## [1] 4526
# Divide nos níveis de Admit e calcula a marginal e todas as
# condicionais. Retorna as probabilidades.
probs <- by(data = da,
INDICES = da$Admit,
FUN = function(a_subset) {
with(a_subset, {
a <- as.character(a_subset$Admit[1])
# Freq(A = a) e Prob(A = a)
f_a <- sum(Freq)
p_a <- f_a/tot
# Freq(g | A = a) e Prob(g | A = a)
f_g.a <- tapply(Freq, Gender, sum)
p_g.a <- f_g.a/f_a
# Freq(d | A = a) e Prob(g | A = a).
f_d.a <- tapply(Freq, Dept, sum)
p_d.a <- f_d.a/f_a
cat("------------------------------\n")
cat(sprintf("P(A = %s): %0.3f", a, p_a), "\n\n")
cat(sprintf("P(G = %s | A = %s): %0.3f",
names(p_g.a), a, p_g.a),
sep = "\n")
cat("\n")
cat(sprintf("P(D = %s | A = %s): %0.3f",
names(p_d.a), a, p_d.a),
sep = "\n")
cat("\n")
probs <- (p_a) * outer(p_g.a, p_d.a, FUN = "*")
probs <- plyr::adply(probs, seq_along(dim(probs)))
names(probs) <- c("Gender", "Dept", a)
return(probs)
})
})
## ------------------------------
## P(A = Admitted): 0.388
##
## P(G = Male | A = Admitted): 0.683
## P(G = Female | A = Admitted): 0.317
##
## P(D = A | A = Admitted): 0.342
## P(D = B | A = Admitted): 0.211
## P(D = C | A = Admitted): 0.183
## P(D = D | A = Admitted): 0.153
## P(D = E | A = Admitted): 0.084
## P(D = F | A = Admitted): 0.026
##
## ------------------------------
## P(A = Rejected): 0.612
##
## P(G = Male | A = Rejected): 0.539
## P(G = Female | A = Rejected): 0.461
##
## P(D = A | A = Rejected): 0.120
## P(D = B | A = Rejected): 0.078
## P(D = C | A = Rejected): 0.215
## P(D = D | A = Rejected): 0.189
## P(D = E | A = Rejected): 0.158
## P(D = F | A = Rejected): 0.241
## da$Admit: Admitted
## Gender Dept Admitted
## 1 Male A 0.090644116
## 2 Female A 0.042144218
## 3 Male B 0.055804198
## 4 Female B 0.025945691
## 5 Male C 0.048564735
## 6 Female C 0.022579764
## 7 Male D 0.040571160
## 8 Female D 0.018863219
## 9 Male E 0.022170857
## 10 Female E 0.010308153
## 11 Male F 0.006937819
## 12 Female F 0.003225681
## --------------------------------------------------------
## da$Admit: Rejected
## Gender Dept Rejected
## 1 Male A 0.03952272
## 2 Female A 0.03383124
## 3 Male B 0.02559453
## 4 Female B 0.02190878
## 5 Male C 0.07095042
## 6 Female C 0.06073318
## 7 Male D 0.06226019
## 8 Female D 0.05329439
## 9 Male E 0.05202237
## 10 Female E 0.04453087
## 11 Male F 0.07952162
## 12 Female F 0.06807008
# Fazendo a junção recursiva.
probs <- Reduce(merge, probs)
# probs
A <- levels(da$Admit)
probs$class <- A[apply(probs[, A],
MARGIN = 1,
FUN = which.max)]
probs
## Gender Dept Admitted Rejected class
## 1 Female A 0.042144218 0.03383124 Admitted
## 2 Female B 0.025945691 0.02190878 Admitted
## 3 Female C 0.022579764 0.06073318 Rejected
## 4 Female D 0.018863219 0.05329439 Rejected
## 5 Female E 0.010308153 0.04453087 Rejected
## 6 Female F 0.003225681 0.06807008 Rejected
## 7 Male A 0.090644116 0.03952272 Admitted
## 8 Male B 0.055804198 0.02559453 Admitted
## 9 Male C 0.048564735 0.07095042 Rejected
## 10 Male D 0.040571160 0.06226019 Rejected
## 11 Male E 0.022170857 0.05202237 Rejected
## 12 Male F 0.006937819 0.07952162 Rejected
#-----------------------------------------------------------------------
# Repetindo com os dados do HairEyeColor.
HairEyeColor
## , , Sex = Male
##
## Eye
## Hair Brown Blue Hazel Green
## Black 32 11 10 3
## Brown 53 50 25 15
## Red 10 10 7 7
## Blond 3 30 5 8
##
## , , Sex = Female
##
## Eye
## Hair Brown Blue Hazel Green
## Black 36 9 5 2
## Brown 66 34 29 14
## Red 16 7 7 7
## Blond 4 64 5 8
# Transforma em tabela.
da <- as.data.frame(HairEyeColor)
da
## Hair Eye Sex Freq
## 1 Black Brown Male 32
## 2 Brown Brown Male 53
## 3 Red Brown Male 10
## 4 Blond Brown Male 3
## 5 Black Blue Male 11
## 6 Brown Blue Male 50
## 7 Red Blue Male 10
## 8 Blond Blue Male 30
## 9 Black Hazel Male 10
## 10 Brown Hazel Male 25
## 11 Red Hazel Male 7
## 12 Blond Hazel Male 5
## 13 Black Green Male 3
## 14 Brown Green Male 15
## 15 Red Green Male 7
## 16 Blond Green Male 8
## 17 Black Brown Female 36
## 18 Brown Brown Female 66
## 19 Red Brown Female 16
## 20 Blond Brown Female 4
## 21 Black Blue Female 9
## 22 Brown Blue Female 34
## 23 Red Blue Female 7
## 24 Blond Blue Female 64
## 25 Black Hazel Female 5
## 26 Brown Hazel Female 29
## 27 Red Hazel Female 7
## 28 Blond Hazel Female 5
## 29 Black Green Female 2
## 30 Brown Green Female 14
## 31 Red Green Female 7
## 32 Blond Green Female 8
# Total de casos.
tot <- sum(da$Freq)
tot
## [1] 592
# Divide nos níveis de Eye e calcula a marginal e todas as
# condicionais. Retorna as probabilidades.
probs <- by(data = da,
INDICES = da$Eye,
FUN = function(a_subset) {
with(a_subset, {
a <- as.character(a_subset$Eye[1])
# Freq(A = a) e Prob(A = a)
f_a <- sum(Freq)
p_a <- f_a/tot
# Freq(g | A = a) e Prob(g | A = a)
f_g.a <- tapply(Freq, Sex, sum)
p_g.a <- f_g.a/f_a
# Freq(d | A = a) e Prob(g | A = a).
f_d.a <- tapply(Freq, Hair, sum)
p_d.a <- f_d.a/f_a
cat("------------------------------\n")
cat(sprintf("P(%s): %0.3f", a, p_a), "\n\n")
cat(sprintf("P(%s | %s): %0.3f",
names(p_g.a), a, p_g.a),
sep = "\n")
cat("\n")
cat(sprintf("P(%s | %s): %0.3f",
names(p_d.a), a, p_d.a),
sep = "\n")
cat("\n")
probs <- (p_a) * outer(p_g.a, p_d.a, FUN = "*")
probs <- plyr::adply(probs, seq_along(dim(probs)))
names(probs) <- c("Sex", "Hair", a)
return(probs)
})
})
## ------------------------------
## P(Brown): 0.372
##
## P(Male | Brown): 0.445
## P(Female | Brown): 0.555
##
## P(Black | Brown): 0.309
## P(Brown | Brown): 0.541
## P(Red | Brown): 0.118
## P(Blond | Brown): 0.032
##
## ------------------------------
## P(Blue): 0.363
##
## P(Male | Blue): 0.470
## P(Female | Blue): 0.530
##
## P(Black | Blue): 0.093
## P(Brown | Blue): 0.391
## P(Red | Blue): 0.079
## P(Blond | Blue): 0.437
##
## ------------------------------
## P(Hazel): 0.157
##
## P(Male | Hazel): 0.505
## P(Female | Hazel): 0.495
##
## P(Black | Hazel): 0.161
## P(Brown | Hazel): 0.581
## P(Red | Hazel): 0.151
## P(Blond | Hazel): 0.108
##
## ------------------------------
## P(Green): 0.108
##
## P(Male | Green): 0.516
## P(Female | Green): 0.484
##
## P(Black | Green): 0.078
## P(Brown | Green): 0.453
## P(Red | Green): 0.219
## P(Blond | Green): 0.250
# probs
# Fazendo a junção recursiva.
probs <- Reduce(merge, probs)
# probs
A <- levels(da$Eye)
probs$class <- A[apply(probs[, A],
MARGIN = 1,
FUN = which.max)]
probs
## Sex Hair Brown Blue Hazel Green class
## 1 Female Black 0.063697789 0.01791326 0.012532694 0.004091005 Brown
## 2 Female Blond 0.006557125 0.08419233 0.008355129 0.013091216 Blue
## 3 Female Brown 0.111471130 0.07523570 0.045117698 0.023727829 Brown
## 4 Female Red 0.024355037 0.01522627 0.011697181 0.011454814 Brown
## 5 Male Black 0.051167076 0.01587052 0.012805144 0.004354941 Brown
## 6 Male Blond 0.005267199 0.07459145 0.008536763 0.013935811 Blue
## 7 Male Brown 0.089542383 0.06665619 0.046098518 0.025258657 Brown
## 8 Male Red 0.019563882 0.01348994 0.011951468 0.012193834 Brown
Usando o pacote e1071
library(e1071)
# help(naiveBayes, h = "html")
# Converte array para tabela.
hec <- as.data.frame(HairEyeColor)
# O dado está agregado. As linhas terão que ser repetidas baseado em
# Freq.
r <- rep(seq_len(nrow(hec)), hec$Freq)
hec$Freq <- NULL
hec <- hec[r, ]
str(hec)
## 'data.frame': 592 obs. of 3 variables:
## $ Hair: Factor w/ 4 levels "Black","Brown",..: 1 1 1 1 1 1 1 1 1 1 ...
## $ Eye : Factor w/ 4 levels "Brown","Blue",..: 1 1 1 1 1 1 1 1 1 1 ...
## $ Sex : Factor w/ 2 levels "Male","Female": 1 1 1 1 1 1 1 1 1 1 ...
# Faz o ajuste do modelo.
nb <- naiveBayes(Eye ~ Hair + Sex, data = hec)
# Classe e métodos.
class(nb)
## [1] "naiveBayes"
methods(class = class(nb))
## [1] predict print
## see '?methods' for accessing help and source code
##
## Naive Bayes Classifier for Discrete Predictors
##
## Call:
## naiveBayes.default(x = X, y = Y, laplace = laplace)
##
## A-priori probabilities:
## Y
## Brown Blue Hazel Green
## 0.3716216 0.3631757 0.1570946 0.1081081
##
## Conditional probabilities:
## Hair
## Y Black Brown Red Blond
## Brown 0.30909091 0.54090909 0.11818182 0.03181818
## Blue 0.09302326 0.39069767 0.07906977 0.43720930
## Hazel 0.16129032 0.58064516 0.15053763 0.10752688
## Green 0.07812500 0.45312500 0.21875000 0.25000000
##
## Sex
## Y Male Female
## Brown 0.4454545 0.5545455
## Blue 0.4697674 0.5302326
## Hazel 0.5053763 0.4946237
## Green 0.5156250 0.4843750
# pred <- with(hec,
# expand.grid(Sex = levels(Sex),
# Hair = levels(Hair),
# KEEP.OUT.ATTRS = FALSE))
pred <- probs[, c("Sex", "Hair")]
# As probabilidades para cada classe.
probs[, A]/rowSums(probs[, A])
## Brown Blue Hazel Green
## 1 0.64842420 0.1823516 0.12757903 0.04164519
## 2 0.05844359 0.7504054 0.07446918 0.11668187
## 3 0.43619684 0.2944043 0.17654972 0.09284919
## 4 0.38823137 0.2427143 0.18645887 0.18259542
## 5 0.60770172 0.1884912 0.15208428 0.05172281
## 6 0.05147206 0.7289217 0.08342285 0.13618337
## 7 0.39349647 0.2929225 0.20258120 0.11099986
## 8 0.34203113 0.2358418 0.20894493 0.21318218
predict(nb, newdata = pred, type = "raw")
## Brown Blue Hazel Green
## [1,] 0.64842420 0.1823516 0.12757903 0.04164519
## [2,] 0.05844359 0.7504054 0.07446918 0.11668187
## [3,] 0.43619684 0.2944043 0.17654972 0.09284919
## [4,] 0.38823137 0.2427143 0.18645887 0.18259542
## [5,] 0.60770172 0.1884912 0.15208428 0.05172281
## [6,] 0.05147206 0.7289217 0.08342285 0.13618337
## [7,] 0.39349647 0.2929225 0.20258120 0.11099986
## [8,] 0.34203113 0.2358418 0.20894493 0.21318218
# A classe predita.
pred$class <- predict(nb, newdata = pred, type = "class")
pred
## Sex Hair class
## 1 Female Black Brown
## 2 Female Blond Blue
## 3 Female Brown Brown
## 4 Female Red Brown
## 5 Male Black Brown
## 6 Male Blond Blue
## 7 Male Brown Brown
## 8 Male Red Brown