How to add data in object with index in R? - r
first at all: I am completly new to R. So please excuse me if the question is a little crude.
I am trying multivariate clustering of functional data. Therefore I used Ramsay & Silvermans fda-Package to build basis spline expansion systems, fill them with curves and applyed the funclust to the dataset.
The funclust-Function gives a proposal as vector for the clustering named as clsResult e.g.
clsResult <- c(2,2,2,3,3,2,3,2,2)
At the next step I would like to calculate statistical measures like mean, standard deviation,... That is why I wish to separate the data for each class and calculate the statistics.
An example for the mean calculation:
uniGroups <- sort(unique(as.vector(clsResult)))
j = 1
for (i in uniGroups) {
obsItems <- which(cls %in% i)
fdClsMean[j] <- mean.fd(fdData[obsItems])
plot(fdClsMean[j])
j <- j + 1
}
The variable $fdClsMean$ should now contain the the mean-Curves for classes 2 (j=1) and 3 (j=2).
But by doing this way, I get the following error message:
Error in basisobj$type : $ operator is invalid for atomic vectors
In addition: Warning messages:
1: In fdClsMean[j] <- mean.fd(fdData[obsItems]) :
number of items to replace is not a multiple of replacement length
2: In fdClsMean[j] <- mean.fd(fdData[obsItems]) :
number of items to replace is not a multiple of replacement length
If you have some idea to fix my problem, it would deeply grateful to share this to fix my issues...
library("fda", lib.loc="~/R/win-library/3.3")
library("Funclustering", lib.loc="~/R/win-library/3.3")
library("RColorBrewer")
dataParam1 <- structure(c(0.983981396374184, 0.985667565176901, 0.987353733979619,
0.989039902782336, 0.990726071585054, 0.992412240387771, 0.994098409190489,
0.995784577993206, 0.997470746795924, 0.999156915598641, 1.00084308440136,
1.00252925320408, 1.00421542200679, 1.00590159080951, 1.00758775961223,
1.00927392841495, 1.01096009721766, 1.01264626602038, 1.0143324348231,
1.01601860362582), .Dim = c(20L, 1L))
dataParam2 <- structure(c(0.935807922166589, 0.943068751205336, 0.950253873594361,
0.957301033607757, 0.964196288650217, 0.970959127061196, 0.977617918964004,
0.984189979476357, 0.990668963023258, 0.997013182869952, 1.00323559960119,
1.00938298993635, 1.01547786768659, 1.02152013701955, 1.0274999384715,
1.0334274313317, 1.03932634191985, 1.04522750712415, 1.05115275864212,
1.05710855288827, 0.944940959736965, 0.952240113360859, 0.959441049641086,
0.966488172817292, 0.97341343344192, 0.980222400271887, 0.986902496653507,
0.993448451457477, 0.99986985906694, 1.00619310390116, 1.01243170737101,
1.01858974507763, 1.02466601555031, 1.03064904117653, 1.03651652181871,
1.04225550204583, 1.04786681255322, 1.05337761542761, 1.05881863137361,
1.06421715026136, 0.942134107403247, 0.949453882063492, 0.956590162743654,
0.96357651793391, 0.970434299161641, 0.977175121667198, 0.983804637900584,
0.990326873791272, 0.996747607095444, 1.00308113105998, 1.00933426721898,
1.01549301552775, 1.02154277232314, 1.02747204422399, 1.0332709082207,
1.03893203367462, 1.04446158372569, 1.04987525096791, 1.05520008265379,
1.06046511659515, 0.940314383500459, 0.947443682667925, 0.954466467035383,
0.961381593377821, 0.968188153734298, 0.974880350284026, 0.981455066595135,
0.987919638428396, 0.994283132996982, 1.00055457342423, 1.00673992698461,
1.01284173849434, 1.01885881474915, 1.02478559454537, 1.03060319500227,
1.03629277173835, 1.04185574786414, 1.04730757048597, 1.05268469714051,
1.05802280631965, 0.942200273210682, 0.949537004317527, 0.956623599167406,
0.963557498320244, 0.970424531942181, 0.977192573805136, 0.983814211488919,
0.990277133991018, 0.996653057498476, 1.00300075654431, 1.00933625505411,
1.01557529576456, 1.02166231349206, 1.02762357846321, 1.03350687583051,
1.0393552762534, 1.04517784054144, 1.05097645707751, 1.05675187074763,
1.06250633686837, 0.918631352137535, 0.926168759248379, 0.933383610717465,
0.940494686251366, 0.947502148141247, 0.954389475599439, 0.961178237128648,
0.967896560645279, 0.974461153761216, 0.980830749331793, 0.987116074571801,
0.99342184407008, 0.99972724615763, 1.00590479212328, 1.01188232533948,
1.01767723457145, 1.02335415372681, 1.02896316014817, 1.03452862636983,
1.0400636313845, 0.948799842055992, 0.95604267242623, 0.963156714842769,
0.970143065897736, 0.97700934008937, 0.983765186828579, 0.990417394142179,
0.996974994464174, 1.00344983548711, 1.00984462195143, 1.01615468562631,
1.02236814859822, 1.02847302994779, 1.0344602037918, 1.04032333101854,
1.04606311135653, 1.0517058460477, 1.05728582670374, 1.06283690174272,
1.06837903584947, 0.937423306587466, 0.944893372711674, 0.952215313085228,
0.959400162368507, 0.966459044310274, 0.973365235191435, 0.980115166296175,
0.986739018932661, 0.993253673429198, 0.999669550405327, 1.0059957825912,
1.012243755661, 1.01842325413489, 1.02453580456187, 1.03057996323426,
1.03655461352516, 1.04246624447002, 1.04832385360279, 1.05413680517058,
1.05991330934091, 0.929064626164736, 0.936318053087355, 0.943487918232746,
0.950544729360738, 0.957477543275641, 0.964285599365032, 0.970974339717291,
0.977549594039067, 0.984023864258173, 0.990424135490678, 0.996768075950284,
1.00305982852269, 1.00929091001667, 1.01544534554472, 1.02150212798765,
1.02744072592741, 1.03324516748151, 1.03892952896684, 1.04453104163349,
1.05008784822354, 0.93174505802589, 0.93913180070802, 0.946369086629952,
0.953430967475995, 0.960342639111208, 0.967156853413704, 0.973912193750937,
0.980515241879027, 0.986922063141707, 0.993226171372671, 0.999502978127663,
1.00578905610495, 1.01204829399176, 1.01823525590035, 1.02431611212046,
1.03025344575662, 1.03602479561377, 1.04166823872877, 1.04723886048702,
1.05279403456375), .Dim = c(20L, 10L))
dataParam3 <- structure(c(1.09752068287775, 1.06097903366602, 1.02849490570095,
1.00006829898254, 0.975699213510778, 0.955387649285669, 0.939133606307212,
0.926937084575411, 0.918798084090263, 0.91471660485177, 0.914692646859928,
0.918726210114739, 0.926817294616202, 0.938965900364315, 0.955172027359076,
0.975435675600487, 0.999756845088542, 1.02813553582325, 1.06057174780459,
1.09706548103259, 1.15326107555771, 1.09807034962895, 1.05134196032301,
1.0130026453226, 0.98288375314881, 0.960918342480959, 0.947105518522033,
0.941413952185788, 0.942411639052145, 0.946950432124294, 0.95383973098054,
0.963066506646878, 0.974630759123311, 0.98853248840984, 1.00477169450647,
1.02334837741319, 1.04426253713001, 1.06751417365691, 1.09310328699392,
1.12102987714102, 1.08280188279282, 1.0339980008814, 0.99569456675958,
0.96693069628092, 0.945845840346565, 0.930481541243696, 0.919050991554413,
0.911059810335648, 0.906507018011789, 0.905392614582835, 0.907716600048786,
0.913478974409641, 0.9226797376654, 0.935318889816062, 0.951396430861627,
0.970912360802095, 0.993866679637463, 1.02025938736774, 1.05009048399292,
1.083359969513, 1.07095942421253, 1.03585502956334, 1.00549026148582,
0.979865119979976, 0.958979605045805, 0.942833716683301, 0.931427454892467,
0.924759134770715, 0.922715496413862, 0.925000988457256, 0.931232021681892,
0.940974907301548, 0.954057033380912, 0.970475602146626, 0.99023061359869,
1.0133220677371, 1.03974996456186, 1.06951430407298, 1.10261508627044,
1.13905231115425, 1.11173319871675, 1.07474700125511, 1.04289364687089,
1.015144362519, 0.991499148199451, 0.971958003912224, 0.956520929657326,
0.94518792543476, 0.937950419475085, 0.934666308796689, 0.935126761169374,
0.939286949471352, 0.947146873129281, 0.95870653214316, 0.97396592651299,
0.992925056238774, 1.01558392132051, 1.0419425217582, 1.07200085755185,
1.10575892870146, 1.18452158624921, 1.12370399561361, 1.07335363604345,
1.03347050753872, 1.00405461009944, 0.985101985787768, 0.975484170734052,
0.971553828495674, 0.970543650731045, 0.971115755631005, 0.973165208428402,
0.97669200912324, 0.981696157715515, 0.988177654205224, 0.996136498592366,
1.00557269087694, 1.01648623105895, 1.02887711913838, 1.04274535511525,
1.05809093898954, 1.06649113627055, 1.024759151488, 0.991993644427598,
0.966493902211868, 0.946597045425109, 0.931024085529654, 0.919567682099019,
0.912227835133204, 0.90900454463221, 0.909897810596039, 0.914907633024689,
0.92403008262567, 0.936993197222042, 0.953120075509914, 0.972106114234723,
0.993944684266615, 1.01863578560559, 1.04617941825165, 1.07657558220479,
1.10982427746502, 1.1253871751946, 1.08517168478315, 1.05718721613491,
1.03386322378679, 1.01386163522085, 0.996961380709181, 0.983162460251796,
0.972464873848689, 0.96486862149986, 0.960373703205309, 0.958980118965034,
0.960687868779034, 0.965496952647307, 0.973407370569853, 0.984419122546672,
0.998532208577764, 1.01574662866313, 1.03606238280277, 1.05947947099668,
1.08599789324487, 1.10370505705101, 1.07105955490089, 1.042537295611,
1.01813827918133, 0.997862505611908, 0.981709974902708, 0.969649294946133,
0.961487003409706, 0.957046106397668, 0.956305216070678, 0.959264332428738,
0.965923455471853, 0.976282585200022, 0.990341721613246, 1.00810086471153,
1.02956001449487, 1.05471917096326, 1.08357833411671, 1.11613750395523,
1.15239574124661, 1.17014704608091, 1.12539391342114, 1.08622797779053,
1.05264923918907, 1.02465769761678, 1.00225335307363, 0.985253167489029,
0.972675875945994, 0.963752595681981, 0.958418763926775, 0.956674380680374,
0.95851944594278, 0.963953959713992, 0.972977921994012, 0.985591332782836,
1.00179419208046, 1.02158649988689, 1.04496825620213, 1.07193946102617,
1.10250011435902), .Dim = c(20L, 10L))
dataParam4 <- structure(c(0.998027622801379, 0.998139005663452, 0.998271051914594,
0.998423328203811, 0.998595824570253, 0.998787296486765, 0.998993932660538,
0.999210129159112, 0.999431146138834, 0.999656257754324, 0.999883808694126,
1.00011168941983, 1.00033957014554, 1.00056745087124, 1.00079533159695,
1.00102321232266, 1.00125109304836, 1.00147897377407, 1.00170685449977,
1.00193473522548, 0.998889268641521, 0.998995305981988, 0.999133764074945,
0.99928651296306, 0.999452207584217, 0.999630847938417, 0.99982243402566,
1.00002692932507, 1.00024266452332, 1.00046582375815, 1.00069345965806,
1.00092367291089, 1.00115613664618, 1.00139085086393, 1.00162781556414,
1.0018670307468, 1.00210849641193, 1.0023521950849, 1.00259752350583,
1.0028432697472, 0.99858396998391, 0.99870387003, 0.998847936377362,
0.999013112737924, 0.999193672030613, 0.999385662628316, 0.999586590108664,
0.999795769265012, 1.00001319873968, 1.00023887520213, 1.00047211431565,
1.00071073589431, 1.00095287258822, 1.00119740014348, 1.00144380788341,
1.00169207895861, 1.00194221336906, 1.00219421111478, 1.00244807219575,
1.00270379661199, 0.998270181390647, 0.998401339075749, 0.998551858486823,
0.998714133501672, 0.998888127245082, 0.999073839717051, 0.999271270917581,
0.999480396599729, 0.999699586873158, 0.999924714214518, 1.00015335625382,
1.00038507691478, 1.00061973867722, 1.00085733931215, 1.00109787881957,
1.00134135719949, 1.00158777258983, 1.00183667764293, 1.00208661796178,
1.00233662699637, 0.998524744128797, 0.99863486766656, 0.998766395000859,
0.998919231110539, 0.999090190884781, 0.99927303979413, 0.999465840024052,
0.999667849206214, 0.99987677069341, 1.00009092850323, 1.00030946243406,
1.00053217357039, 1.00075802790152, 1.00098471847949, 1.00121141596579,
1.00143811345209, 1.0016648109384, 1.0018915084247, 1.002118205911,
1.00234490339731, 0.997142773287418, 0.997216060623538, 0.997337368533094,
0.99748694099883, 0.997653350796102, 0.997832448382706, 0.998024129720826,
0.998228394810461, 0.998445199575133, 0.9986718900988, 0.998902679532502,
0.999136069032265, 0.999372057841899, 0.999610645961405, 0.999851833390782,
1.00009562013003, 1.00034200617915, 1.00059099153814, 1.00084257620701,
1.00109676018574, 0.998774949267013, 0.998910297833251, 0.999061521216158,
0.999227984680012, 0.999409687603104, 0.999605338922452, 0.99980970198149,
1.00001925408346, 1.00023376857386, 1.00045324545269, 1.00067768471994,
1.00090707945052, 1.00114095033083, 1.00137806194375, 1.00161725633342,
1.00185762361078, 1.00209895072581, 1.00234123762244, 1.00258448430066,
1.00282869076048, 0.998235072519545, 0.998344557202282, 0.998473860627503,
0.998622982795209, 0.9987919237054, 0.998980556065077, 0.999185038787191,
0.999398230779131, 0.999618154290144, 0.999844806347269, 1.00007793486253,
1.00031476590786, 1.00055208167417, 1.00078941271967, 1.00102675904437,
1.00126412064827, 1.00150149743951, 1.00173888541517, 1.00197627612265,
1.00221366684226, 0.997626171909553, 0.997748769141173, 0.997905556676881,
0.998072158983953, 0.998246774313143, 0.998429402664452, 0.998620044037878,
0.998818696371925, 0.999024892332026, 0.999237142122056, 0.999454583203959,
0.999677175584942, 0.999904919265005, 1.00013781424415, 1.00037584615344,
1.00061802820279, 1.00086189544351, 1.00110629255917, 1.00135119016537,
1.00159658826211, 0.99786182119536, 0.997943059648897, 0.998068582740041,
0.998214894107906, 0.998377432849961, 0.998555103351116, 0.998747881433229,
0.998955724328998, 0.999175663350038, 0.999400370426972, 0.999626749674934,
0.999854748906657, 1.00008436812214, 1.00031560732139, 1.0005484665044,
1.00078294567116, 1.00101904482169, 1.00125676395599, 1.00149610307404,
1.00173700388097), .Dim = c(20L, 10L))
# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Param1
# ####################################################################################
xVal <- as.vector(dataParam1)
nObs <- dim(dataParam3)[2]
# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Param2
# ####################################################################################
# Build the basis expansion system for Param2
fdBasisParam2 <- create.bspline.basis(rangeval = range(xVal), norder=6)
# Calculate the coefficients for Param2 as matrix at once
yVal <- as.matrix(dataParam2)
fdParam2 <- Data2fd(argvals=xVal,y=yVal, basisobj=fdBasisParam2, lambda=0)
round(fdParam2$coefs, 4)
rm(yVal)
plot(fdParam2)
# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Param3
# ####################################################################################
# Build the basis expansion system for Param3
fdBasisParam3 <- create.bspline.basis(rangeval = range(xVal), norder=3)
# Calculate the coefficients for Param3 as matrix at once
yVal <- as.matrix(dataParam3)
fdParam3 <- Data2fd(argvals=xVal,y=yVal, basisobj=fdBasisParam3, lambda=0)
round(fdParam3$coefs, 4)
rm(yVal)
plot(fdParam3)
# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Param4
# ####################################################################################
# Build the basis expansion system for Param4
fdBasisParam4 <- create.bspline.basis(rangeval = range(xVal), norder=3)
# Calculate the coefficients for Param4 as matrix at once
yVal <- as.matrix(dataParam4)
fdParam4 <- Data2fd(argvals=xVal,y=yVal, basisobj=fdBasisParam4, lambda=0)
round(fdParam4$coefs, 4)
rm(yVal)
plot(fdParam4)
# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Clustering multivariate functional Data with funclust algorithm
# ####################################################################################
# -- Create a multivariate functional data object
allFd <- list(fdParam2,fdParam3,fdParam4)
# -- clustering in K classes
K <- 3 # Number of clusters
thd <- 0.05 # Threshold for Cantell Scree-Test
hard <- FALSE
nLoop <- 1
cls <- c()
tik <- c()
for (i in 1:nLoop) {
clustResult <- funclust(allFd,
K=K,
thd=thd,
increaseDimension=FALSE,
hard=hard
)
tik <- rbind(round((clustResult$tik)*100, 2))
cls <- rbind(cls,clustResult$cls)
}
#
# Calculation of class-specific characteristics
#
uniGroups <- sort(unique(as.vector(cls)))
fbParam2ClsMean <- list()
fbParam3ClsMean <- list()
fbParam4ClsMean <- list()
j <- 1
for (i in uniGroups) {
obsItems <- which(cls %in% i)
# Mean values
fbParam2ClsMean[[j]] <- mean.fd(fdParam2[obsItems])
fbParam3ClsMean[[j]] <- mean.fd(fdParam3[obsItems])
fbParam4ClsMean[[j]] <- mean.fd(fdParam4[obsItems])
j <- j+1
}
plot(fbParam2ClsMean)
plot(fbParam3ClsMean)
plot(fbParam4ClsMean)
The additional errors are caused by the output of mean.fd(fdData[obsItems]), not a single element. you need list() to put it. (listname[[1]] means 1st object in the list.)
fdClsMean <- list()
for (i in uniGroups) {
obsItems <- which(cls %in% i) # what is cls ??
fdClsMean[[j]] <- mean.fd(fdData[obsItems])
plot(fdClsMean[[j]])
j <- j + 1
}
[Edited]
Your fbParamXClsMean is a class list and have three fd objects. you need to pick up one fd object when you draw it.
for example;
plot(fbParam2ClsMean[[1]])
plot(fbParam2ClsMean[[2]], add=T, col=2, lty=2)
plot(fbParam2ClsMean[[3]], add=T, col=3, lty=3)
# if use for()
a <- FALSE
for(i in 1:3) {
plot(fbParam2ClsMean[[i]], col = i, lty = i, add = a)
a <- TRUE
}
Thank you very much for your help. Sure your solution works definitely but I would like to use the capabilities of the fda-package - it provides several calculation and plotting methods for handling of these objects.
Therefore I'd like to propose my solution:
Create an fd-object based on an existing b-spline expansion system (e.g. called fdParam2Mean). While the matrix fdParam2ClsMean$coefs is filled with zeros, I delete these manually.
fdParam2ClsMean <- fd(coef=NULL, basisobj=fdParam2$basis)
fdParam2ClsMean$coefs <- fdParam2ClsMean$coefs[,-1]
Request the class names and store them in uniGroups
uniGroups <- sort(unique(as.vector(cls)))
Iterate through the uniGroups for calculation of statistics (like mean, standard deviation etc.)
for (i in uniGroups) {
obsItems <- which(cls %in% i)
# Mean values
fdParam2ClsMean$coefs <- cbind(fdParam2ClsMean$coefs, as.array(mean.fd(fdParam2[obsItems])$coefs))
}
After these operations you are able to process this objects with mathematical operations or for example use the plot() command.
plot(fdParam2ClsMean)
Related
Creating a function to loop columns through an equation in R
Solution (thanks #Peter_Evan!) in case anyone coming across this question has a similar issue
(Original question is below)
## get all slopes (lm coefficients) first
# list of subfields of interest to loop through
sf <- c("left_presubiculum", "right_presubiculum",
"left_subiculum", "right_subiculum", "left_CA1", "right_CA1",
"left_CA3", "right_CA3", "left_CA4", "right_CA4", "left_GC-ML-DG",
"right_GC-ML-DG")
# dependent variables are sf, independent variable common to all models in the inner lm() call is ICV
# applies the lm(subfield ~ ICV, dataset = DF) to all subfields of interest (sf) specified previously
lm.results <- lapply(sf, function(dv) {
temp.lm <- lm(get(dv) ~ ICV, data = DF)
coef(temp.lm)
})
# returns a list, where each element is a vector of coefficients
# do.call(rbind, ) will paste them together
lm.coef <- data.frame(sf = sf,
do.call(rbind, lm.results))
# tidy up name of intercept variable
names(lm.coef)[2] <- "intercept"
lm.coef
## set up all components for the equation
# matrix to store output
out <- matrix(ncol = length(sf), nrow = NROW(DF))
# name the rows after each subject
row.names(out) <- DF$Subject
# name the columns after each subfield
colnames(out) <- sf
# nested for loop that goes by subject (j) and subfield (i)
for(j in DF$Subject){
for (i in sf) {
slope <- lm.coef[lm.coef$sf == i, "ICV"]
out[j,i] <- as.numeric( DF[DF$Subject == j, i] - (slope * (DF[DF$Subject == j, "ICV"] - mean(DF$ICV))) )
}
}
# check output
out
===============
Original Question:
I have a dataframe (DF) with 13 columns (12 different brain subfields, and one column containing total intracranial volume(ICV)) and 50 rows (each a different participant). I'm trying to automate an equation being looped over every column for each participant.
The data:
structure(list(Subject = c("sub01", "sub02", "sub03", "sub04",
"sub05", "sub06", "sub07", "sub08", "sub09", "sub10", "sub11",
"sub12", "sub13", "sub14", "sub15", "sub16", "sub17", "sub18",
"sub19", "sub20"), ICV = c(1.50813, 1.3964237, 1.6703585, 1.4641886,
1.6351018, 1.5524641, 1.4445532, 1.6384505, 1.6152434, 1.5278011,
1.4788126, 1.4373356, 1.4109637, 1.3634952, 1.3853583, 1.4855268,
1.6082085, 1.5644998, 1.5617522, 1.4304141), left_subiculum = c(411.225013,
456.168033, 492.968477, 466.030173, 533.95505, 476.465524, 448.278213,
476.45566, 422.617374, 498.995121, 450.773906, 461.989663, 549.805272,
452.619547, 457.545623, 451.988333, 475.885847, 490.127968, 470.686415,
494.06548), left_CA1 = c(666.893596, 700.982955, 646.21927, 580.864234,
721.170599, 737.413139, 737.683665, 597.392434, 594.343911, 712.781376,
733.157168, 699.820162, 701.640861, 690.942843, 606.259484, 731.198846,
567.70879, 648.887718, 726.219904, 712.367433), left_presubiculum = c(325.779458,
391.252815, 352.765098, 342.67797, 390.885737, 312.857458, 326.916867,
350.657957, 325.152464, 320.718835, 273.406949, 305.623938, 371.079722,
315.058313, 311.376271, 319.56678, 348.343569, 349.102678, 322.39908,
306.966008), `left_GC-ML-DG` = c(327.037756, 305.63224, 328.945065,
238.920358, 319.494513, 305.153183, 311.347404, 259.259723, 295.369164,
312.022281, 324.200989, 314.636501, 306.550385, 311.399107, 295.108592,
356.197094, 251.098248, 294.76349, 317.308576, 301.800253), left_CA3 = c(275.17038,
220.862237, 232.542718, 170.088695, 234.707172, 210.803287, 246.861975,
171.90896, 220.83478, 236.600832, 246.842024, 239.677362, 186.599097,
224.362411, 229.9142, 293.684776, 172.179779, 202.18936, 232.5666,
221.896625), left_CA4 = c(277.614028, 264.575987, 286.605092,
206.378619, 281.781858, 258.517989, 269.354864, 226.269982, 256.384436,
271.393257, 277.928824, 265.051581, 262.307377, 266.924683, 263.038686,
306.133918, 226.364556, 262.42823, 264.862956, 255.673948), right_subiculum = c(468.762375,
445.35738, 446.536018, 456.73484, 521.041823, 482.768261, 487.2911,
456.39996, 445.392976, 476.146498, 451.775611, 432.740085, 518.170065,
487.642399, 405.564237, 487.188989, 467.854363, 479.268714, 473.212833,
472.325916), right_CA1 = c(712.973011, 717.815214, 663.637105,
649.614586, 711.844375, 779.212704, 862.784416, 648.925038, 648.180611,
760.761704, 805.943016, 717.486756, 801.853608, 722.213109, 621.676321,
791.672796, 605.35667, 637.981476, 719.805053, 722.348921), right_presubiculum = c(327.285242,
364.937865, 288.322641, 348.30058, 341.309111, 279.429847, 333.096795,
342.184296, 364.245998, 350.707173, 280.389853, 276.423658, 339.439377,
321.534798, 302.164685, 328.365751, 341.660085, 305.366589, 320.04127,
303.83284), `right_GC-ML-DG` = c(362.391907, 316.853532, 342.93274,
282.550769, 339.792696, 357.867386, 342.512721, 277.797528, 309.585721,
343.770416, 333.524912, 302.505077, 309.063135, 291.29361, 302.510461,
378.682679, 255.061044, 302.545288, 313.93902, 297.167161), right_CA3 = c(307.007404,
243.839349, 269.063801, 211.336979, 249.283479, 276.092623, 268.183349,
202.947849, 214.642782, 247.844657, 291.206598, 235.864996, 222.285729,
201.427853, 237.654913, 321.338801, 199.035108, 243.204203, 236.305659,
213.386702), right_CA4 = c(312.164065, 272.905586, 297.99392,
240.765062, 289.98697, 306.459566, 284.533068, 245.965817, 264.750571,
296.149675, 290.66935, 264.821461, 264.920869, 246.267976, 266.07378,
314.205819, 229.738951, 274.152503, 256.414608, 249.162404)), row.names = c(NA,
-20L), class = c("tbl_df", "tbl", "data.frame"))
The equation:
adjustedBrain(participant1) = rawBrain(participant1) - slope*[ICV(participant1) - (mean of all ICV measures included in the calculation of the slope)]
The code (which is not working and I was hoping for some pointers):
adjusted_Brain <- function(DF, subject) {
subfields <- colnames(select(DF, "left_presubiculum", "right_presubiculum",
"left_subiculum", "right_subiculum", "left_CA1", "right_CA1",
"left_CA3", "right_CA3", "left_CA4", "right_CA4", "left_GC-ML-DG",
"right_GC-ML-DG"))
out <- matrix(ncol = length(subfields), nrow = NROW(DF))
for (i in seq_along(subfields)) {
DF[i] = DF[DF$Subject == "subject", "i"] -
slope * (DF[DF$Subject == "subject", "ICV"] -
mean(DF$ICV))
}
}
Getting this error:
Error: Can't subset columns that don't exist.
x Column `i` doesn't exist.
A few notes:
The slopes for each subject for each subfield will be different (and will come from a regression) -> is there a way to specify that in the function so the slope (coefficient from the appropriate regression equation) gets called in?
I have my nrow set to the number of participants right now in the output because I'd like to have this run through EVERY subject across EVERY subfield and spit out a matrix with all the adjusted brain volumes... But that seems very complicated and so for now I will just settle for running each participant separately.
Any help is greatly appreciated!
As others have noted in the comments, there are quite a few syntax issues that prevent your code from running, as well as a few unstated requirements. That aside, I think there is enough to recommend a few improvements that you can hopefully build on. Here are the top line changes:
You likely don't need this to be a function, but rather a nested for loop (if you want to do this with base R). As written, the code isn't flexible enough to merit a function. If you intend to apply this many times across different datasets, a function might make sense. However, it will require a much larger rewrite.
Assuming you are fitting a simple regression via lm, then you can pull out the coefficient of interest via the $ operator and indexing (see below). Some thought will need to go into how to handle different models in the loop. Here, we assume you only need one coefficient from one model.
There are a few areas where the syntax is incorrect and a review of sub setting in base R would be helpful. Others have pointed out in the comments were some of these are.
Here is one approach were we loop through each subject (j) through each feature or subfield (i) and store them in a matrix (out). This is just an approach and will almost certainly need tweaking on your end!
#NOTE: the dataset your provided is saved as x in this example.
#fit a linear model - here we assume there is only one coef. of interest, but you may need to alter
# depending on how the slope changes in each calculation
reg <- lm(ICV ~ right_CA3, x)
# view the coeff.
reg$coefficients
# pull out the slope by getting the coeff. of interest (via index) from the reg object
slope <- reg$coefficients[[1]]
# list of features/subfeilds to loop through
sf <- c("left_presubiculum", "right_presubiculum",
"left_subiculum", "right_subiculum", "left_CA1", "right_CA1",
"left_CA3", "right_CA3", "left_CA4", "right_CA4", "left_GC-ML-DG",
"right_GC-ML-DG")
# matrix to store output
out <- matrix(ncol = length(sf), nrow = NROW(x))
#name the rows after each subject
row.names(out) <- x$Subject
#name the columns after each sub feild
colnames(out) <- sf
# nested for loop that goes by subject (j) and features/subfeilds (i)
for(j in x$Subject){
for (i in sf) {
out[j,i] <- as.numeric( x[x$Subject == j, i] - (slope * (x[x$Subject == j, "ICV"] - mean(x$ICV))) )
}
}
# check output
out
Properly calling variable name when creating multiple Benford plots
I am creating Benford plots for all the numeric variables in my dataset. https://en.wikipedia.org/wiki/Benford%27s_law
Running a single variable
#install.packages("benford.analysis")
library(benford.analysis)
plot(benford(iris$Sepal.Length))
Looks great. And the legend says "Dataset: iris$Sepal.Length", perfect!.
Using apply to run 4 variables,
apply(iris[1:4], 2, function(x) plot(benford(x)))
Creates four plots, however, each plot's legend says "Dataset: x"
I attempted to use a for loop,
for (i in colnames(iris[1:4])){
plot(benford(iris[[i]]))
}
This creates four plots, but now the legends says "Dataset: iris[[i]]". And I would like the name of the variable on each chart.
I tried a different loop, hoping to get titles with an evaluated parsed string like "iris$Sepal.Length":
for (i in colnames(iris[1:4])){
plot(benford(eval(parse(text=paste0("iris$", i)))))
}
But now the legend says "Dataset: eval(parse(text=paste0("iris$", i)))".
AND, Now I've run into the infamous eval(parse(text=paste0( (eg: How to "eval" results returned by "paste0"? and R: eval(parse(...)) is often suboptimal )
I would like labels such as "Dataset: iris$Sepal.Length" or "Dataset: Sepal.Length". How can I create multiple plots with meaningfully variable names in the legend?
This is happening because of the first line within the benford function=:
benford <- function(data, number.of.digits = 2, sign = "positive", discrete=TRUE, round=3){
data.name <- as.character(deparse(substitute(data)))
Source: https://github.com/cran/benford.analysis/blob/master/R/functions-new.R
data.name is then used to name your graph. Whatever variable name or expression you pass to the function will unfortunately be caught by the deparse(substitute()) call, and will be used as the name for your graph.
One short-term solution is to copy and rewrite the function:
#install.packages("benford.analysis")
library(benford.analysis)
#install.packages("data.table")
library(data.table) # needed for function
# load hidden functions into namespace - needed for function
r <- unclass(lsf.str(envir = asNamespace("benford.analysis"), all = T))
for(name in r) eval(parse(text=paste0(name, '<-benford.analysis:::', name)))
benford_rev <- function{} # see below
for (i in colnames(iris[1:4])){
plot(benford_rev(iris[[i]], data.name = i))
}
This has negative side effects of:
Not being maintainable with package revisions
Fills your GlobalEnv with normally hidden functions in the package
So hopefully someone can propose a better way!
benford_rev <- function(data, number.of.digits = 2, sign = "positive", discrete=TRUE, round=3, data.name = as.character(deparse(substitute(data)))){ # changed
# removed line
benford.digits <- generate.benford.digits(number.of.digits)
benford.dist <- generate.benford.distribution(benford.digits)
empirical.distribution <- generate.empirical.distribution(data, number.of.digits,sign, second.order = FALSE, benford.digits)
n <- length(empirical.distribution$data)
second.order <- generate.empirical.distribution(data, number.of.digits,sign, second.order = TRUE, benford.digits, discrete = discrete, round = round)
n.second.order <- length(second.order$data)
benford.dist.freq <- benford.dist*n
## calculating useful summaries and differences
difference <- empirical.distribution$dist.freq - benford.dist.freq
squared.diff <- ((empirical.distribution$dist.freq - benford.dist.freq)^2)/benford.dist.freq
absolute.diff <- abs(empirical.distribution$dist.freq - benford.dist.freq)
### chi-squared test
chisq.bfd <- chisq.test.bfd(squared.diff, data.name)
### MAD
mean.abs.dev <- sum(abs(empirical.distribution$dist - benford.dist)/(length(benford.dist)))
if (number.of.digits > 3) {
MAD.conformity <- NA
} else {
digits.used <- c("First Digit", "First-Two Digits", "First-Three Digits")[number.of.digits]
MAD.conformity <- MAD.conformity(MAD = mean.abs.dev, digits.used)$conformity
}
### Summation
summation <- generate.summation(benford.digits,empirical.distribution$data, empirical.distribution$data.digits)
abs.excess.summation <- abs(summation - mean(summation))
### Mantissa
mantissa <- extract.mantissa(empirical.distribution$data)
mean.mantissa <- mean(mantissa)
var.mantissa <- var(mantissa)
ek.mantissa <- excess.kurtosis(mantissa)
sk.mantissa <- skewness(mantissa)
### Mantissa Arc Test
mat.bfd <- mantissa.arc.test(mantissa, data.name)
### Distortion Factor
distortion.factor <- DF(empirical.distribution$data)
## recovering the lines of the numbers
if (sign == "positive") lines <- which(data > 0 & !is.na(data))
if (sign == "negative") lines <- which(data < 0 & !is.na(data))
if (sign == "both") lines <- which(data != 0 & !is.na(data))
#lines <- which(data %in% empirical.distribution$data)
## output
output <- list(info = list(data.name = data.name,
n = n,
n.second.order = n.second.order,
number.of.digits = number.of.digits),
data = data.table(lines.used = lines,
data.used = empirical.distribution$data,
data.mantissa = mantissa,
data.digits = empirical.distribution$data.digits),
s.o.data = data.table(second.order = second.order$data,
data.second.order.digits = second.order$data.digits),
bfd = data.table(digits = benford.digits,
data.dist = empirical.distribution$dist,
data.second.order.dist = second.order$dist,
benford.dist = benford.dist,
data.second.order.dist.freq = second.order$dist.freq,
data.dist.freq = empirical.distribution$dist.freq,
benford.dist.freq = benford.dist.freq,
benford.so.dist.freq = benford.dist*n.second.order,
data.summation = summation,
abs.excess.summation = abs.excess.summation,
difference = difference,
squared.diff = squared.diff,
absolute.diff = absolute.diff),
mantissa = data.table(statistic = c("Mean Mantissa",
"Var Mantissa",
"Ex. Kurtosis Mantissa",
"Skewness Mantissa"),
values = c(mean.mantissa = mean.mantissa,
var.mantissa = var.mantissa,
ek.mantissa = ek.mantissa,
sk.mantissa = sk.mantissa)),
MAD = mean.abs.dev,
MAD.conformity = MAD.conformity,
distortion.factor = distortion.factor,
stats = list(chisq = chisq.bfd,
mantissa.arc.test = mat.bfd)
)
class(output) <- "Benford"
return(output)
}
I have just updated the package (GitHub version) to allow for a user supplied name.
Now the function has a new parameter called data.name in which you can provide a character vector with the name of the data and override the default. Thus, for your example you can simply run the following code.
First install the GitHub version (I will submit this version to CRAN soon).
devtools::install_github("carloscinelli/benford.analysis") # install new version
Now you can provide the name of the data inside the for loop:
library(benford.analysis)
for (i in colnames(iris[1:4])){
plot(benford(iris[[i]], data.name = i))
}
And all the plots will have the correct naming as you wish (below).
Created on 2019-08-10 by the reprex package (v0.2.1)
R: nel2igraph and PN.amalgamation - igraph not correctly produced
I encounter a problem with the package shp2graph. I want to use the function PN.amalgamation which works fine (see below). Afterwards, I would like to create an igraph object. Here the code fails to do that. I can create igraph objects just fine with every non-amalgamated shp2graph object. Here my sample code, which largely is a copy paste from the description of the package shp2graph: library(igraph) library(shp2graph) data(ORN) rtNEL<-readshpnw(ORN.nt, ELComputed=TRUE) res.sl<-SL.extraction(rtNEL[[2]],rtNEL[[3]]) res.me<-ME.simplification(res.sl[[1]],res.sl[[2]],DegreeL=res.sl[[4]]) res.pn<-PN.amalgamation(res.me[[1]],res.me[[2]],DegreeL=res.me[[4]]) ptcoords<-Nodes.coordinates(res.pn[[1]]) plot(ORN.nt) points(ptcoords, col="green") plot(ORN.nt) points(Nodes.coordinates(rtNEL[[2]]), col="red") # igraph created from amalgamation is wrong test <- nel2igraph(nodelist= res.pn[[1]], edgelist=res.pn[[2]], Directed = TRUE) plot(test,vertex.size=1,edge.width=1,edge.arrow.size=0,vertex.label=NA) # res.me is one step before amalgamation test <- nel2igraph(nodelist= res.me[[1]], edgelist=res.me[[2]], Directed = TRUE) plot(test,vertex.size=1,edge.width=1,edge.arrow.size=0,vertex.label=NA) Any help is appreciated.
I have found that the bug lies somehow in the interaction with the igraph package. The issue is that the labels of the nodes create by PN.amalgamation are not continuous anymore; some are missing, since we deleted them. However, igraph somehow still tries to create them and gives then the following warning:
For anyone having the same trouble here a work-around, which re-indeces the labels.
Create your own nel2igraph function:
nel2igraph_corr <- function (nodelist, edgelist, weight = NULL, eadf = NULL, Directed = FALSE)
{
nodes <- nodelist[, 1]
Ne <- length(edgelist[, 1])
Nn <- length(nodes)
for (i in 1:Nn) {
kk <- nodelist[i,][[1]]
edgelist[which(edgelist[,c(2)]==kk),2] <- i
edgelist[which(edgelist[,c(3)]==kk),3] <- i
nodelist[i,][[1]] <- i
}
if (!is.null(weight)) {
if (length(weight) != Ne && is.numeric(weight))
stop("Please give right edge weight, which must be numeric and the same length as edges elment")
}
if (!is.null(eadf)) {
if (length(eadf[, 1]) != Ne)
stop("The eadf must be numeric and the same length as edges elment")
}
gr <- graph.edgelist(unique(edgelist[, c(2, 3)]), directed = T)
gr <- set.vertex.attribute(gr, "x", V(gr), Nodes.coordinates(nodelist)[,1])
gr <- set.vertex.attribute(gr, "y", V(gr), Nodes.coordinates(nodelist)[,
2])
gr.es <- E(gr)
if (!is.null(weight))
gr <- set.edge.attribute(gr, "weight", gr.es, weight)
if (!is.null(eadf)) {
eanms <- colnames(eadf)
n <- length(eanms)
for (i in 1:n) gr <- set.edge.attribute(gr, eanms[i],
gr.es, eadf[, i])
}
gr
}
How to visulize the convolution layer and feature layer in mxnet after cnn was finished trained?
I want to plot or visualize the result of each layers out from a trained CNN with mxnet in R. Like w´those abstract art from what a nn's each layer can see. But I don't know how. Please somebody help me. One way I can think out is to put the weights and bias back to every step and plot the step out. But when I try to put model$arg.params$convolution0_weight back to mx.symbol.Convolution(), I get Error in mx.varg.symbol.Convolution(list(...)) : ./base.h:291: Unsupported parameter type object type for argument weight, expect integer, logical, or string. Can anyone help me?
I thought out one way, but encounter a difficulty at one step. Here is what I did. I found all the trained cnn's parameters inmodel$arg.params , and to compute with parameters we can use mx.nd... founctions as bellow: `#convolution 1_result conv1_result<- mxnet::mx.nd.Convolution(data=mx.nd.array(train_array),weight=model$arg.params$convolution0_weight,bias=model$arg.params$convolution0_bias,kernel=c(8,8),num_filter = 50) str(conv1_result) tanh1_result<-mx.nd.Activation(data= conv1_result, act_type = "sigmoid") pool1_result <- mx.nd.Pooling(data = tanh1_result, pool_type = "avg", kernel = c(4,4), stride = c(4,4)) conv2 result conv2_result<- mxnet::mx.nd.Convolution(data=pool1_result,weight=model$arg.params$convolution1_weight,bias=model$arg.params$convolution1_bias,kernel=c(5,5),num_filter = 50) tanh2_result<-mx.nd.Activation(data= conv1_result, act_type = "sigmoid") pool2_result <- mx.nd.Pooling(data = tanh1_result, pool_type = "avg", kernel = c(4,4), stride = c(4,4)) 1st fully connected layer result flat_result <- mx.nd.flatten(data = pool2_result) fcl_1_result <- mx.nd.FullyConnected(data = flat_result,weight = model$arg.params$fullyconnected0_weight,bias = model$arg.params$fullyconnected0_bias, num_hidden = 500) tanh_3_result <- mx.nd.Activation(data = fcl_1_result, act_type = "tanh") 2nd fully connected layer result fcl_2_result <- mx.nd.FullyConnected(data = tanh_3,weight = model$arg.params$fullyconnected1_weight,bias = model$arg.params$fullyconnected1_bias, num_hidden =100)` but when I came to mx.nd.FullyConnected() step , I encountered not sufficient memory(i have 16 GB RAM) and R crashed. So, does anyone know how to batch_size the input data in mx.nd.FullyConnected(), or any method to make mx.nd.FullyConnected() run successfully as mx.model.FeedForward.create() did?
Here is the code that can help you to achieve what you want. The code below displays activations of 2 convolution layers of LeNet. The code gets as an input MNIST dataset, which is 28x28 grayscale images (downloaded automatically), and produces images as activations.
You can grab outputs from executor. To see the list of available outputs use names(executor$ref.outputs)
The result of each output is available as a matrix with values in [-1; 1] range. The dimensions of the matrix depends on parameters of the layer. The code use these matrices to display as greyscaled images where -1 is white pixel, 1 - black pixel. (most of the code is taken from https://github.com/apache/incubator-mxnet/issues/1152 and massaged a little bit)
The code is a self sufficient to run, but I have noticed that if I build the model second time in the same R session, the names of ouputs get different indices, and later the code fails because the expected names of outputs are hard coded. So if you decide to create a model more than once, you will need to restart R session.
Hope it helps and you can adjust this example to your case.
library(mxnet)
download.file('https://apache-mxnet.s3-accelerate.dualstack.amazonaws.com/R/data/mnist_csv.zip', destfile = 'mnist_csv.zip')
unzip('mnist_csv.zip', exdir = '.')
train <- read.csv('train.csv', header=TRUE)
data.x <- train[,-1]
data.x <- data.x/255
data.y <- train[,1]
val_ind = 1:100
train.x <- data.x[-val_ind,]
train.x <- t(data.matrix(train.x))
train.y <- data.y[-val_ind]
val.x <- data.x[val_ind,]
val.x <- t(data.matrix(val.x))
val.y <- data.y[val_ind]
train.array <- train.x
dim(train.array) <- c(28, 28, 1, ncol(train.x))
val.array <- val.x
dim(val.array) <- c(28, 28, 1, ncol(val.x))
# input layer
data <- mx.symbol.Variable('data')
# first convolutional layer
convLayer1 <- mx.symbol.Convolution(data=data, kernel=c(5,5), num_filter=30)
convAct1 <- mx.symbol.Activation(data=convLayer1, act_type="tanh")
poolLayer1 <- mx.symbol.Pooling(data=convAct1, pool_type="max", kernel=c(2,2), stride=c(2,2))
# second convolutional layer
convLayer2 <- mx.symbol.Convolution(data=poolLayer1, kernel=c(5,5), num_filter=60)
convAct2 <- mx.symbol.Activation(data=convLayer2, act_type="tanh")
poolLayer2 <- mx.symbol.Pooling(data=convAct2, pool_type="max",
kernel=c(2,2), stride=c(2,2))
# big hidden layer
flattenData <- mx.symbol.Flatten(data=poolLayer2)
hiddenLayer <- mx.symbol.FullyConnected(flattenData, num_hidden=500)
hiddenAct <- mx.symbol.Activation(hiddenLayer, act_type="tanh")
# softmax output layer
outLayer <- mx.symbol.FullyConnected(hiddenAct, num_hidden=10)
LeNet1 <- mx.symbol.SoftmaxOutput(outLayer)
# Group some output layers for visual analysis
out <- mx.symbol.Group(c(convAct1, poolLayer1, convAct2, poolLayer2, LeNet1))
# Create an executor
executor <- mx.simple.bind(symbol=out, data=dim(val.array), ctx=mx.cpu())
# Prepare for training the model
mx.set.seed(0)
# Set a logger to keep track of callback data
logger <- mx.metric.logger$new()
# Using cpu by default, but set gpu if your machine has a supported one
devices=mx.cpu(0)
# Train model
model <- mx.model.FeedForward.create(LeNet1, X=train.array, y=train.y,
eval.data=list(data=val.array, label=val.y),
ctx=devices,
num.round=1,
array.batch.size=100,
learning.rate=0.05,
momentum=0.9,
wd=0.00001,
eval.metric=mx.metric.accuracy,
epoch.end.callback=mx.callback.log.train.metric(100, logger))
# Update parameters
mx.exec.update.arg.arrays(executor, model$arg.params, match.name=TRUE)
mx.exec.update.aux.arrays(executor, model$aux.params, match.name=TRUE)
# Select data to use
mx.exec.update.arg.arrays(executor, list(data=mx.nd.array(val.array)), match.name=TRUE)
# Do a forward pass with the current parameters and data
mx.exec.forward(executor, is.train=FALSE)
# List of outputs available.
names(executor$ref.outputs)
# Plot the filters of a sample from validation set
sample_index <- 99 # sample number in validation set. Change it to if you want to see other samples
activation0_filter_count <- 30 # number of filters of the "convLayer1" layer
par(mfrow=c(6,5), mar=c(0.1,0.1,0.1,0.1)) # number of rows x columns in output
dim(executor$ref.outputs$activation0_output)
for (i in 1:activation0_filter_count) {
outputData <- as.array(executor$ref.outputs$activation0_output)[,,i,sample_index]
image(outputData,
xaxt='n', yaxt='n',
col=gray(seq(1,0,-0.1)))
}
activation1_filter_count <- 60 # number of filters of the "convLayer2" layer
dim(executor$ref.outputs$activation1_output)
par(mfrow=c(6,10), mar=c(0.1,0.1,0.1,0.1)) # number of rows x columns in output
for (i in 1:activation1_filter_count) {
outputData <- as.array(executor$ref.outputs$activation1_output)[,,i,sample_index]
image(outputData,
xaxt='n', yaxt='n',
col=gray(seq(1,0,-0.1)))
}
As a result you should see the following images for a validation sample #2 (use RStudio left and right arrows to navigate between them).
How to use a script on multiple excel working sheets in r studio
I have a rather long script, at least for me, but i'm new in R.
It looks like this
#DATA IS LOADED
library(xlsx)
df=read.xlsx2("/Users/emiliemariafalkkallenbach/Documents/Norsk_Institut_for_vandforskning/Chase_DK.xlsx",sheetIndex=1)
df[df==""]<- NA
df=data.matrix(df)
df=data.frame(df)
attach(df)
Phyto=df[,1:6]
Submerged=df[,7:12]
Benthic=df[13:18]
# PHTYOPLANKTON
#making of boundaries
a<-(ifelse(P_Resp<=0,(1-P_Acdev),1/(1+P_Acdev)))
b=(0.95+a)/2
c=2*a-b
d=2*c-a
#Weighted boundaries
e=0.95*P_weight
e=sum(e)
f=b*P_weight
f=sum(f)
g=a*P_weight
g=sum(g)
h=c*P_weight
g=sum(g)
i=d*P_weight
i=sum(i)
#EQR weighted
j=P_EQR*P_weight
j=sum(j)
#complete
l <- ifelse(is.na(rowSums(Phyto)),1,0)
m=sum(l)
#SUBMERGED VEGETATION
#Overall assesment
y=ifelse(m<=0,j,"")
z=ifelse(y!="NA",0,(ifelse(y>f,1,(ifelse(y>g,2,(ifelse(y>h,3,(ifelse(y>i,4,5)))))))))
#making of boundaries
a.sub<-(ifelse(S_Resp<=0,(1-S_Acdev),1/(1+S_Acdev)))
a.sub=sum(a.sub)
b.sub=(0.95+a.sub)/2
b.sub=sum(b.sub)
c.sub=2*a.sub-b.sub
c.sub=sum(c.sub)
d.sub=2*c.sub-a.sub
d.sub=sum(d.sub)
#Weighted boundaries
e.sub=0.95*S_weight
e.sub=sum(e)
f.sub=b.sub*S_weight
f.sub=sum(f)
g.sub=a.sub*S_weight
g.sub=sum(g)
h.sub=c.sub*S_weight
h.sub=sum(h)
i.sub=d.sub*S_weight
i.sub=sum(i)
#EQR.sub weighted
j.sub=S_EQR*S_weight
j.sub=sum(j.sub)
#complete.sub
l.sub <- ifelse(is.na(rowSums(Submerged)),1,0)
m.sub=sum(l.sub)
#Overall Assesment
q.sub=m.sub*0.75
y.sub=ifelse(m.sub<=0,j.sub,"")
z.sub=ifelse(y.sub!="NA",(ifelse(y.sub>f.sub,1,(ifelse(y.sub>g.sub,2,(ifelse(y.sub>h.sub,3,(ifelse(y.sub>i.sub,4,5)))))))),0)
BENTHIC INVERTEBRATES
#making of boundaries
a.ben<-(ifelse(B_Resp<=0,(1-B_Acdev),1/(1+B_Acdev)))
b.ben=(0.95+a.ben)/2
c.ben=2*a.ben-b.ben
d.ben=2*c.ben-a.ben
#Weighted boundaries
e.ben=0.95*B_weight
e.ben=sum(e.ben)
f.ben=b.ben*B_weight
f.ben=sum(f.ben)
g.ben=a.ben*B_weight
g.ben=(sum(g.ben))
h.ben=c.ben*B_weight
h.ben=sum(h.ben)
i.ben=d.ben*B_weight
i.ben=sum(i.ben)
#EQR weighted
j.ben=B_EQR*B_weight
#Complete
l.ben <- ifelse(is.na(rowSums(Benthic)),1,0)
m.ben=sum(l.sub)
#ChkAccDev
n.ben=ifelse(B_Resp>0,0.53,1.1)
o.ben=ifelse(B_Acdev<0.15,-1,0)
p.ben=ifelse(B_Acdev>n.ben,1,o.ben)
#Overall Assesment
q.ben=m.ben*0.75
y.ben=ifelse(m.ben<1,j.ben,"")
z.ben=ifelse(y.ben!="NA",ifelse(y.ben>f.ben,1,(ifelse(y.ben>g.ben,2,(ifelse(y.ben>h.ben,3,(ifelse(y.ben>i.ben,4,5))))))),0)
#Final assesment
Z=max(na.omit(c(z,z.sub,z.ben)))
#Overall assesment
SCORE=(ifelse(Z<=1 && Z<2,"HIGH",(ifelse(Z>=2 && Z<3,"GOOD",(ifelse(Z>=3 && Z<4,"MODERATE",(ifelse(Z>=4 && Z<5,"BAD",(ifelse(Z>=5,"POOR","NA"))))))))))
SCORE
#Pie Chart
library('plotrix')
Phyto=33.3
Submerged=33.3
Benthic=33.3
total=100
Slices1=c=(1)
total=100
iniR=0.2
Slices1=c=(1)
pie(1, radius=iniR, init.angle=90, col=c('white'), border = NA, labels='Overall')
colors=c(ifelse(z<=1,"blue", ifelse(z<=2,"green",ifelse(z<=3,"yellow",ifelse(z<=4,"orange",ifelse(z<=5,"red","red"))))), ifelse(z.sub<=1,"blue", ifelse(z.sub<=2,"green", ifelse(z.sub<=3,"yellow",ifelse(z.sub<=4,"orange",ifelse(z.sub<=5,"red","red"))))),ifelse(z.ben<=1,"blue", ifelse(z.ben<=2,"green", ifelse(z.ben<=3, "yellow", ifelse(z.ben<=4,"orange",ifelse(z.ben<=5,"red","red"))))))
floating.pie(0,0,c(Phyto, Submerged, Benthic),radius=5*iniR, startpos=pi/2, col=colors,border=NA)
Slices1=c=(1)
total=100
iniR=0.2 # initial radius
colorst=c(ifelse(Z<=1,"blue", ifelse(Z<=2,"green",ifelse(Z<=3,"yellow",ifelse(Z<=4,"orange",ifelse(Z<=5,"red","red"))))))
floating.pie(0,0,c(total),radius=3*iniR, startpos=pi/2, col=colorst,border=NA)
angles=as.numeric(c(-10,75,80))
pie.labels(0,0,angles,c("Phyto","Submerged","Benthic"),radius=1, bg="white")
pie.labels(0,0,0,c("Overall Assessment"),radius=-0.3)
I guess it does not matter, what is into my script.
At the moment it only runs the first sheet in excel, but I have several and would like to run them on all of them.
The outcome should be a table looking like this
z z.sub z.ben Z Pie-chart (only if possible)
Sheet 1 0 NA NA High
Sheet 2 ... ... ... ...
Sheet 3 ... ... ... ...
I'm sorry if this is an ordinary question!
Hope someone is able to help
Thanks!
a better way to read xls is the library readxl.
# remove "#" if you don't have these libraries installed already
# install.packages("readxl") # faster excel reader
# install.packages("data.table") # faster everything, in this case rbindlist
library(readxl)
library(data.table)
sheets = 1:5 # index numbers or names of the sheets you want to read
readmysheets = function(sheets) {
df = read_excel(file="myexcel.xls", sheets)
}
myfiles = lapply(sheets, readmysheets) # apply the indices/names on the readmysheets function
# you now have a list:
str(myfiles)
# bind the separate sheets together
together = rbindlist(myfiles, fill = T)
Wrap the body of your script into a "for" loop. You have several was of doing this, here are two.
# pre-allocate an object to write to
out <- matrix(rep(NA, numsheets * numcols), ncols = numcols))
for (i in 1:nsheets) {
df=read.xlsx2(".../Chase_DK.xlsx", sheetIndex = i)
#... do calculations
out[, i] <- c(z, z.sub, z.ben, Z)
}
# second way, no need to pre-allocate anything
sapply(1:nsheets, FUN = function(x) {
df=read.xlsx2(".../Chase_DK.xlsx", sheetIndex = x)
#... do calculations
out <- c(z, z.sub, z.ben, Z) # specify what you wish the function to return
return(out) # sapply will try to simplify the combined result on its own
})