Related
I have two lengthy data sets with several columns and different lengths, for this example lets subset to few rows and just 3 columns:
Temp <- c(12.9423 ,12.9446 ,12.9412 ,12.9617 ,12.9742 ,12.9652 ,12.9463, 12.9847 ,12.9778,
12.9589, 12.9305, 12.9275 ,12.8569 ,12.8531 ,12.9092, 12.9471, 12.9298, 12.9266,
12.9374 ,12.9385, 12.9505, 12.9510, 12.9632 ,12.9621 ,12.9571, 12.9492 ,12.8988,
12.8895 ,12.8777, 12.8956, 12.8748 ,12.7850 ,12.7323, 12.7546 ,12.7375 ,12.7020,
12.7172, 12.7015, 12.6960, 12.6944, 12.6963, 12.6928, 12.6930 ,12.6883 ,12.6913)
Density <- c(26.38635 ,26.38531 ,26.38429, 26.38336, 26.38268 ,26.38242, 26.38265, 26.38343,
26.38486, 26.38697 ,26.38945, 26.39188, 26.39365, 26.39424 ,26.39376 ,26.39250,
26.39084 ,26.38912 ,26.38744 ,26.38587, 26.38456 ,26.38367, 26.38341 ,26.38398,
26.38547 ,26.38793 ,26.39120 ,26.39509, 26.39955 ,26.40455, 26.41002, 26.41578,
26.42126, 26.42593 ,26.42968, 26.43255 ,26.43463, 26.43603 ,26.43693 ,26.43750,
26.43787, 26.43815, 26.43841 ,26.43871 ,26.43904)
po4 <- c(0.4239840 ,0.4351156, 0.4456128, 0.4542392, 0.4608510, 0.4656445, 0.4690847,
0.4717291, 0.4742391 ,0.4774904 ,0.4831152, 0.4922122, 0.5029904, 0.5128720,
0.5190209, 0.5191368 ,0.5133212, 0.5027542 ,0.4905301 ,0.4796467 ,0.4708035,
0.4638879, 0.4578364 ,0.4519745, 0.4481336, 0.4483697, 0.4531310, 0.4622930,
0.4750474 ,0.4905152 ,0.5082183 ,0.5278212 ,0.5491580 ,0.5720519, 0.5961127,
0.6207716 ,0.6449603, 0.6675704 ,0.6878331 ,0.7051851,0.7195461, 0.7305200,
0.7359634 ,0.7343541, 0.7283988)
PP14 <- data.frame(Temp,Density,po4) ##df1
temp <- c(13.13875, 13.13477 ,13.12337 ,13.10662 ,13.09798 ,13.09542 ,13.08734 ,13.07616,
13.06671 ,13.05899, 13.05890 ,13.05293 ,13.03322, 13.01515, 13.02552 ,13.01668,
12.99829, 12.97075 ,12.95572 ,12.95045 ,12.94541 ,12.94365 ,12.94609 ,12.94256,
12.93565 ,12.93258 ,12.93489 ,12.93209 ,12.92219 ,12.90730 ,12.90416 ,12.89974,
12.89749 ,12.89626 ,12.89395, 12.89315 ,12.89274, 12.89276 ,12.89293 ,12.89302)
density <- c( 26.35897, 26.36274 ,26.36173 ,26.36401 ,26.36507 ,26.36662 ,26.36838,
26.36996,
26.37286 ,26.37452 ,26.37402, 26.37571 ,26.37776, 26.38008 ,26.37959 ,26.38178,
26.38642 ,26.39158 ,26.39350, 26.39467, 26.39601, 26.39601, 26.39596 ,26.39517,
26.39728 ,26.39766, 26.39774, 26.39699 ,26.40081 ,26.40328 ,26.40416, 26.40486,
26.40513 ,26.40474 ,26.40552 ,26.40584, 26.40613, 26.40602 ,26.40595 ,26.40498)
krho <- c( -9.999999e+06, -1.786843e+00, -9.142976e-01, -9.650734e-01, -2.532397e+00,
-3.760537e+00, -2.622484e+00, -1.776506e+00, -2.028391e+00, -2.225910e+00,
-3.486826e+00, -2.062341e-01, -3.010643e+00, -3.878437e+00, -3.796426e+00,
-3.227138e+00, -3.335446e+00, -3.738037e+00, -4.577778e+00, -3.818099e+00,
-3.891467e+00, -4.585045e+00 ,-3.150283e+00 ,-4.371089e+00 ,-3.902601e+00,
-4.546019e+00, -3.932538e+00, -4.331247e+00, -4.508137e+00, -4.789201e+00,
-4.383820e+00, -4.423486e+00, -4.334641e+00, -4.330544e+00, -4.838604e+00,
-4.729123e+00, -4.381797e+00, -4.207365e+00, -4.276804e+00, -4.001305e+00)
MS14 <- data.frame(temp,density,krho) ##df2
So now I would like to loop through both data sets and check if MS14$density=PP14$Density if it is true then I would like to use the column krho in that row to multiply it by delta po4 that corresponds to the same density so diff(po4) in that row or range. something like
#MS14$krho[i] * diff(PP14$po4)[i]
BUT when I run
PP14$Density == MS14$density
of course it is always FALSE, because the large decimal numbers, none is exactly the same. I solved that by round the numbers to the 3rd decimal, but it should be a way to include that in the code so density +- 0.005 for example. Well or just rounding it to the 3rd decimal like:
PP14$Density_round2 <- round(PP14$Density ,digit=2)
In any case I am not sure if I should use a nested loop to check both columns and make the operations accordingly or if it would be better to create a new data.frame with the intersect of each data.frame:
common <- intersect(PP14$Density, MS14$density)
and then make calculations....(??)
So I would probably need a nested loop like:
{for i:PP14
for j:MS14
new-> PP14$Density[i] == MS14$density[j]
#if new is true then PP14$krho[i]* MS14$diff(po4)[j]#[for that particular row]
#and print it into a new data.frame df3
#}
So please, feel free to suggest the best way to proceed.. there might be several ways to do it..
Thank you so much in advance!!
Ps: suggestions using Matlab are also welcome
Something like this?
compareDec <- function(x, y, digits = NULL, tol = .Machine$double.eps^0.5){
if(is.null(digits)){
abs(x - y) < tol
} else {
round(x, digits = digits) == round(y, digits = digits)
}
}
icomp <- outer(MS14$density, PP14$Density, compareDec, digits = 2)
m <- outer(MS14$krho, c(0, diff(PP14$po4)))
new <- which(icomp, arr.ind = TRUE)
df3 <- cbind.data.frame(new, Prod = m[new])
head(df3)
# row col Prod
#1 17 1 0.00000000
#2 18 1 0.00000000
#3 19 1 0.00000000
#4 20 1 0.00000000
#5 17 2 -0.03712885
#6 18 2 -0.04161033
I am testing fastai tabular model and getting unexpected results.
Basically, I am trying to predict y = x * x using an input dataframe built on random x.
from fastai.tabular import *
# Build input dataframe
SIZE = 10000
df = pd.DataFrame({'x': np.random.randn(SIZE)})
df['y'] = df['x'] ** 2
# Create data object
dep_var = 'y'
cont_names = ['x']
data = (TabularList.from_df(df, cont_names=cont_names)
.split_by_rand_pct(valid_pct=0.1)
.label_from_df(cols=dep_var, label_cls=FloatList)
.databunch())
# Create model and learn
learn = tabular_learner(data, layers=[200,100], metrics=rmse)
learn.fit_one_cycle(5)
#epoch train_loss valid_loss root_mean_squared_error time
#0 0.706821 0.472120 0.467643 00:01
#1 0.275269 0.077311 0.271610 00:01
#2 0.194118 0.133515 0.325397 00:01
#3 0.176048 0.076927 0.187314 00:01
#4 0.163826 0.078179 0.207878 00:01
# Display result
row = df.sample(1).iloc[0]
print(row)
learn.predict(row)
# Typically:
# x = -1.582047 / y = 2.502874 / predicted_y = 2.324813
I'd expect deep learning to perform better so I'm probably doing something wrong here.
Could someone explain why I'm getting such poor results ?
When you square a distribution of random numbers like that, you're bound to wind up with some tiny values of y, which could lead to some floating point arithmetic issues that could affect your results.
I did an experiment where subjects (n = 14) had to respond on a keyboard to stimuli presented on a screen. They could get a monetary penalty for incorrect responses in two different conditions --> these two conditions are called Penalty 4 and Penalty 14 in the followings. I measured the decision time (DT) of these subjects in the task among other variables.
All the data are present in a table called 'OutputTable_Online'. Here is what OutputTable_Online looks like (top part):
OutputTable_Online (bottom part):
What I want to do is to average the variables named "ampl_RFDI_sb", "ampl_RAPB_sb", "ampl_RADM_sb" for each 'Subjectnbr' and each 'Penalty' as a function of the 'StimType'. All the information I need is in OutputTable_Online as can be seen in the images above. Here is the code I use for this:
Melt_OutputTable_Online <- melt(OutputTable_Online,
id.var = c('Subjectnbr', 'Penalty','Trial_Nbr',
'StimType'), measure.var = c('ampl_RFDI_sb', 'ampl_RAPB_sb', 'ampl_RADM_sb',
'ampl_LFDI_sb', 'ampl_LAPB_sb', 'ampl_LADM_sb', 'ampl_RFDI_ss',
'ampl_RAPB_ss', 'ampl_RADM_ss', 'ampl_LFDI_ss', 'ampl_LAPB_ss',
'ampl_LADM_ss', 'ampl_RFDI_sm', 'ampl_RAPB_sm', 'ampl_RADM_sm',
'ampl_LFDI_sm', 'ampl_LAPB_sm', 'ampl_LADM_sm', 'ampl_RFDI_sl',
'ampl_RAPB_sl', 'ampl_RADM_sl', 'ampl_LFDI_sl', 'ampl_LAPB_sl',
'ampl_LADM_sl'))
Cast_Melt_OutputTable_Online <- cast(Melt_OutputTable_Online,
Subjectnbr * Penalty ~ StimType * variable, mean)
Here is the output of this process:
However, as expected, the DT distribution is shifted to the right when the penalty was 14 as subjects waited longer to respond (they were more cautious). Hence, the average DT is longer in the Penalty 14 than in the Penalty 4 condition.
The group-level density distributions for Penalty 4 (black) and Penalty 14 (green) are represented on the figure here; vertical lines represent the group-level average. Here is the code I used to plot this:
OutputTable_Online_DT <- ddply(OutputTable_Online, "Penalty", summarise,
grp.mean=mean(DT))
Density_OutputTable_Online <- ggplot(OutputTable_Online, aes(x = DT,
fill=Penalty))
Density_OutputTable_Online <- Density_OutputTable_Online +
geom_density(aes(y = ..count.., group=Penalty), alpha=0.2)+
geom_vline(data=OutputTable_Online_DT,aes(xintercept=grp.mean,
color=Penalty),linetype="dashed", size=1)+ ggtitle("Density distributions
for both penalty conditions") + scale_color_manual(labels = c("P4", "P14"),
values = c("black", "green"))+ scale_fill_manual(labels = c("P4", "P14"),
values = c("black", "green"))+ labs(x = "DT (ms)", y = "Density of trials
(a.u.)")+ coord_cartesian(ylim=c(0, 3.5), xlim=c(0, 3000))
Density_OutputTable_Online
Here is my issue: when I do the averaging for the variables "ampl_RFDI_sb", "ampl_RAPB_sb", "ampl_RADM_sb", etc as described above, the resulting averages could actually depend on the DT (i.e., as DT is different in the 2 penalty conditions). I would like to get rid of this confounding factor. To do so, **I would like to homogenize the average DT across the two penalty conditions in each subject. I was thinking that one way to do so would be to select in each subject the trials present in the fraction of the distributions plotted above that overlap each other (i.e., where the green distrib overlap the black distrib). Put differently, I would like to have the same distribution of trials in each penalty condition in OutputTable_Online when I plot the density distribution of DTs before doing the averaging procedure for the variables "ampl_RFDI_sb", "ampl_RAPB_sb", "ampl_RADM_sb", etc.
One way to do this would be to equalize the number trials in the Penalty 4 and Penalty 14 conditions in each DT bin. However, I have no idea of how to do this based on the data present in OutputTable_Online as described above.**
Any tip would be very welcome.
Thank you in advance for your help,
Gerard
To be able to get the same DT in both penalty conditions above, I subsetted the table based on bins of DT (using the subset function) and homogenized, for each bin, the number of trials in each condition based on the condition that had the lowest number of trials. To do so, I used the "sample" function. I did that for each subject of the table using a for loop. Here is the code:
# Loop for each Subject.
for (s in c(unique(DF_ampl_sb$Subjectnbr)))
{
tmp1<- subset(DF_ampl_sb,subset=Subjectnbr==s)
tmp2<- subset(tmp1,subset=DT>1&DT<=250)
tmp3<- subset(tmp1,subset=DT>250&DT<=500)
tmp4<- subset(tmp1,subset=DT>500&DT<=750)
tmp5<- subset(tmp1,subset=DT>750&DT<=1000)
tmp6<- subset(tmp1,subset=DT>1000&DT<=1250)
tmp7<- subset(tmp1,subset=DT>1250&DT<=1500)
tmp8<- subset(tmp1,subset=DT>1500&DT<=1750)
tmp9<- subset(tmp1,subset=DT>1750&DT<=2000)
tmp10<- subset(tmp1,subset=DT>2000&DT<=2250)
tmp11<- subset(tmp1,subset=DT>2250&DT<=2500)
tmp12<- subset(tmp1,subset=DT>2500&DT<=2750)
tmp13<- subset(tmp1,subset=DT>2750&DT<=3000)
tmp2_Penalty1<- subset(tmp2,subset=Penalty==1)
tmp2_Penalty2<- subset(tmp2,subset=Penalty==2)
tmp2_Penalty1<- tmp2_Penalty1[sample(nrow(tmp2_Penalty1), min(dim(tmp2_Penalty2)
[1],dim(tmp2_Penalty1)[1])), ]
tmp2_Penalty2<- tmp2_Penalty2[sample(nrow(tmp2_Penalty2), min(dim(tmp2_Penalty2)
[1],dim(tmp2_Penalty1)[1])), ]
tmp3_Penalty1<- subset(tmp3,subset=Penalty==1)
tmp3_Penalty2<- subset(tmp3,subset=Penalty==2)
tmp3_Penalty1<- tmp3_Penalty1[sample(nrow(tmp3_Penalty1), min(dim(tmp3_Penalty2)[1],dim(tmp3_Penalty1)[1])), ]
tmp3_Penalty2<- tmp3_Penalty2[sample(nrow(tmp3_Penalty2), min(dim(tmp3_Penalty2)[1],dim(tmp3_Penalty1)[1])), ]
tmp4_Penalty1<- subset(tmp4,subset=Penalty==1)
tmp4_Penalty2<- subset(tmp4,subset=Penalty==2)
tmp4_Penalty1<- tmp4_Penalty1[sample(nrow(tmp4_Penalty1), min(dim(tmp4_Penalty2)
[1],dim(tmp4_Penalty1)[1])), ]
tmp4_Penalty2<- tmp4_Penalty2[sample(nrow(tmp4_Penalty2), min(dim(tmp4_Penalty2)
[1],dim(tmp4_Penalty1)[1])), ]
tmp5_Penalty1<- subset(tmp5,subset=Penalty==1)
tmp5_Penalty2<- subset(tmp5,subset=Penalty==2)
tmp5_Penalty1<- tmp5_Penalty1[sample(nrow(tmp5_Penalty1), min(dim(tmp5_Penalty2)
[1],dim(tmp5_Penalty1)[1])), ]
tmp5_Penalty2<- tmp5_Penalty2[sample(nrow(tmp5_Penalty2), min(dim(tmp5_Penalty2)
[1],dim(tmp5_Penalty1)[1])), ]
tmp6_Penalty1<- subset(tmp6,subset=Penalty==1)
tmp6_Penalty2<- subset(tmp6,subset=Penalty==2)
tmp6_Penalty1<- tmp6_Penalty1[sample(nrow(tmp6_Penalty1), min(dim(tmp6_Penalty2)[1],dim(tmp6_Penalty1)[1])), ]
tmp6_Penalty2<- tmp6_Penalty2[sample(nrow(tmp6_Penalty2), min(dim(tmp6_Penalty2)[1],dim(tmp6_Penalty1)[1])), ]
tmp7_Penalty1<- subset(tmp7,subset=Penalty==1)
tmp7_Penalty2<- subset(tmp7,subset=Penalty==2)
tmp7_Penalty1<- tmp7_Penalty1[sample(nrow(tmp7_Penalty1), min(dim(tmp7_Penalty2)[1],dim(tmp7_Penalty1)[1])), ]
tmp7_Penalty2<- tmp7_Penalty2[sample(nrow(tmp7_Penalty2), min(dim(tmp7_Penalty2)[1],dim(tmp7_Penalty1)[1])), ]
tmp8_Penalty1<- subset(tmp8,subset=Penalty==1)
tmp8_Penalty2<- subset(tmp8,subset=Penalty==2)
tmp8_Penalty1<- tmp8_Penalty1[sample(nrow(tmp8_Penalty1), min(dim(tmp8_Penalty2)
[1],dim(tmp8_Penalty1)[1])), ]
tmp8_Penalty2<- tmp8_Penalty2[sample(nrow(tmp8_Penalty2), min(dim(tmp8_Penalty2)
[1],dim(tmp8_Penalty1)[1])), ]
tmp9_Penalty1<- subset(tmp9,subset=Penalty==1)
tmp9_Penalty2<- subset(tmp9,subset=Penalty==2)
tmp9_Penalty1<- tmp9_Penalty1[sample(nrow(tmp9_Penalty1), min(dim(tmp9_Penalty2)
[1],dim(tmp9_Penalty1)[1])), ]
tmp9_Penalty2<- tmp9_Penalty2[sample(nrow(tmp9_Penalty2), min(dim(tmp9_Penalty2)
[1],dim(tmp9_Penalty1)[1])), ]
tmp10_Penalty1<- subset(tmp10,subset=Penalty==1)
tmp10_Penalty2<- subset(tmp10,subset=Penalty==2)
tmp10_Penalty1<- tmp10_Penalty1[sample(nrow(tmp10_Penalty1), min(dim(tmp10_Penalty2)
[1],dim(tmp10_Penalty1)[1])), ]
tmp10_Penalty2<- tmp10_Penalty2[sample(nrow(tmp10_Penalty2), min(dim(tmp10_Penalty2)
[1],dim(tmp10_Penalty1)[1])), ]
tmp11_Penalty1<- subset(tmp11,subset=Penalty==1)
tmp11_Penalty2<- subset(tmp11,subset=Penalty==2)
tmp11_Penalty1<- tmp11_Penalty1[sample(nrow(tmp11_Penalty1), min(dim(tmp11_Penalty2)
[1],dim(tmp11_Penalty1)[1])), ]
tmp11_Penalty2<- tmp11_Penalty2[sample(nrow(tmp11_Penalty2), min(dim(tmp11_Penalty2)
[1],dim(tmp11_Penalty1)[1])), ]
tmp12_Penalty1<- subset(tmp12,subset=Penalty==1)
tmp12_Penalty2<- subset(tmp12,subset=Penalty==2)
tmp12_Penalty1<- tmp12_Penalty1[sample(nrow(tmp12_Penalty1), min(dim(tmp12_Penalty2)
[1],dim(tmp12_Penalty1)[1])), ]
tmp12_Penalty2<- tmp12_Penalty2[sample(nrow(tmp12_Penalty2), min(dim(tmp12_Penalty2)
[1],dim(tmp12_Penalty1)[1])), ]
tmp13_Penalty1<- subset(tmp13,subset=Penalty==1)
tmp13_Penalty2<- subset(tmp13,subset=Penalty==2)
tmp13_Penalty1<- tmp13_Penalty1[sample(nrow(tmp13_Penalty1), min(dim(tmp13_Penalty2)
[1],dim(tmp13_Penalty1)[1])), ]
tmp13_Penalty2<- tmp13_Penalty2[sample(nrow(tmp13_Penalty2), min(dim(tmp13_Penalty2)
[1],dim(tmp13_Penalty1)[1])), ]
# Add the content to the data frame (DF_rms_sb) by binding the data (row-binding).
DF_ampl_sb_tmp <- rbind (DF_ampl_sb_tmp,tmp2_Penalty1, tmp2_Penalty2, tmp3_Penalty1,
tmp3_Penalty2, tmp4_Penalty1, tmp4_Penalty2, tmp5_Penalty1, tmp5_Penalty2,
tmp6_Penalty1, tmp6_Penalty2, tmp7_Penalty1, tmp7_Penalty2, tmp8_Penalty1,
tmp8_Penalty2, tmp9_Penalty1, tmp9_Penalty2, tmp10_Penalty1, tmp10_Penalty2,
tmp11_Penalty1, tmp11_Penalty2, tmp12_Penalty1, tmp12_Penalty2,tmp13_Penalty1,
tmp13_Penalty2)
# Remove objects from a specified environment.
rm(tmp1, tmp2_Penalty1, tmp2_Penalty2, tmp3_Penalty1, tmp3_Penalty2, tmp4_Penalty1,
tmp4_Penalty2, tmp5_Penalty1, tmp5_Penalty2, tmp6_Penalty1, tmp6_Penalty2,
tmp7_Penalty1, tmp7_Penalty2, tmp8_Penalty1, tmp8_Penalty2, tmp9_Penalty1,
tmp9_Penalty2, tmp10_Penalty1, tmp10_Penalty2, tmp11_Penalty1, tmp11_Penalty2,
tmp12_Penalty1, tmp12_Penalty2, tmp13_Penalty1, tmp13_Penalty2)
}
}
dim(DF_ampl_sb_tmp)
DF_ampl_sb <- DF_ampl_sb_tmp
There might be another way of subseting the table, here I defined the bins manually in the loop (i.e. from tmp2 to tmp13). However, it already works pretty well. Here is the kind of distribution I obtain before using the code: enter image description here
And after, using it:
enter image description here
Gerard
I have to calculate cosine similarity (patient similarity metric) in R between 48k patients data with some predictive variables. Here is the equation: PSM(P1,P2) = P1.P2/ ||P1|| ||P2||
where P1 and P2 are the predictor vectors corresponding to two different patients, where for example P1 index patient and P2 will be compared with index (P1) and finally pairwise patient similarity metric PSM(P1,P2) will be calculated.
This process will go on for all 48k patients.
I have added sample data-set for 300 patients in a .csv file. Please find the sample data-set here.https://1drv.ms/u/s!AhoddsPPvdj3hVTSbosv2KcPIx5a
First things first: You can find more rigorous treatments of cosine similarity at either of these posts:
Find cosine similarity between two arrays
Creating co-occurrence matrix
Now, you clearly have a mixture of data types in your input, at least
decimal
integer
categorical
I suspect that some of the integer values are Booleans or additional categoricals. Generally, it will be up to you to transform these into continuous numerical vectors if you want to use them as input into the similarity calculation. For example, what's the distance between admission types ELECTIVE and EMERGENCY? Is it a nominal or ordinal variable? I will only be modelling the columns that I trust to be numerical dependent variables.
Also, what have you done to ensure that some of your columns don't correlate with others? Using just a little awareness of data science and biomedical terminology, it seems likely that the following are all correlated:
diasbp_max, diasbp_min, meanbp_max, meanbp_min, sysbp_max and sysbp_min
I suggest going to a print shop and ordering a poster-size printout of psm_pairs.pdf. :-) Your eyes are better at detecting meaningful (but non-linear) dependencies between variable. Including multiple measurements of the same fundamental phenomenon may over-weight that phenomenon in your similarity calculation. Don't forget that you can derive variables like
diasbp_rage <- diasbp_max - diasbp_min
Now, I'm not especially good at linear algebra, so I'm importing a cosine similarity function form the lsa text analysis package. I'd love to see you write out the formula in your question as an R function. I would write it to compare one row to another, and use two nested apply loops to get all comparisons. Hopefully we'll get the same results!
After calculating the similarity, I try to find two different patients with the most dissimilar encounters.
Since you're working with a number of rows that's relatively large, you'll want to compare various algorithmic methodologies for efficiency. In addition, you could use SparkR/some other Hadoop solution on a cluster, or the parallel package on a single computer with multiple cores and lots of RAM. I have no idea whether the solution I provided is thread-safe.
Come to think of it, the transposition alone (as I implemented it) is likely to be computationally costly for a set of 1 million patient-encounters. Overall, (If I remember my computational complexity correctly) as the number of rows in your input increases, the performance could degrade exponentially.
library(lsa)
library(reshape2)
psm_sample <- read.csv("psm_sample.csv")
row.names(psm_sample) <-
make.names(paste0("patid.", as.character(psm_sample$subject_id)), unique = TRUE)
temp <- sapply(psm_sample, class)
temp <- cbind.data.frame(names(temp), as.character(temp))
names(temp) <- c("variable", "possible.type")
numeric.cols <- (temp$possible.type %in% c("factor", "integer") &
(!(grepl(
pattern = "_id$", x = temp$variable
))) &
(!(
grepl(pattern = "_code$", x = temp$variable)
)) &
(!(
grepl(pattern = "_type$", x = temp$variable)
))) | temp$possible.type == "numeric"
psm_numerics <- psm_sample[, numeric.cols]
row.names(psm_numerics) <- row.names(psm_sample)
psm_numerics$gender <- as.integer(psm_numerics$gender)
psm_scaled <- scale(psm_numerics)
pair.these.up <- psm_scaled
# checking for independence of variables
# if the following PDF pair plot is too big for your computer to open,
# try pair-plotting some random subset of columns
# keep.frac <- 0.5
# keep.flag <- runif(ncol(psm_scaled)) < keep.frac
# pair.these.up <- psm_scaled[, keep.flag]
# pdf device sizes are in inches
dev <-
pdf(
file = "psm_pairs.pdf",
width = 50,
height = 50,
paper = "special"
)
pairs(pair.these.up)
dev.off()
#transpose the dataframe to get the
#similarity between patients
cs <- lsa::cosine(t(psm_scaled))
# this is super inefficnet, because cs contains
# two identical triangular matrices
cs.melt <- melt(cs)
cs.melt <- as.data.frame(cs.melt)
names(cs.melt) <- c("enc.A", "enc.B", "similarity")
extract.pat <- function(enc.col) {
my.patients <-
sapply(enc.col, function(one.pat) {
temp <- (strsplit(as.character(one.pat), ".", fixed = TRUE))
return(temp[[1]][[2]])
})
return(my.patients)
}
cs.melt$pat.A <- extract.pat(cs.melt$enc.A)
cs.melt$pat.B <- extract.pat(cs.melt$enc.B)
same.pat <- cs.melt[cs.melt$pat.A == cs.melt$pat.B ,]
different.pat <- cs.melt[cs.melt$pat.A != cs.melt$pat.B ,]
most.dissimilar <-
different.pat[which.min(different.pat$similarity),]
dissimilar.pat.frame <- rbind(psm_numerics[rownames(psm_numerics) ==
as.character(most.dissimilar$enc.A) ,],
psm_numerics[rownames(psm_numerics) ==
as.character(most.dissimilar$enc.B) ,])
print(t(dissimilar.pat.frame))
which gives
patid.68.49 patid.9
gender 1.00000 2.00000
age 41.85000 41.79000
sysbp_min 72.00000 106.00000
sysbp_max 95.00000 217.00000
diasbp_min 42.00000 53.00000
diasbp_max 61.00000 107.00000
meanbp_min 52.00000 67.00000
meanbp_max 72.00000 132.00000
resprate_min 20.00000 14.00000
resprate_max 35.00000 19.00000
tempc_min 36.00000 35.50000
tempc_max 37.55555 37.88889
spo2_min 90.00000 95.00000
spo2_max 100.00000 100.00000
bicarbonate_min 22.00000 26.00000
bicarbonate_max 22.00000 30.00000
creatinine_min 2.50000 1.20000
creatinine_max 2.50000 1.40000
glucose_min 82.00000 129.00000
glucose_max 82.00000 178.00000
hematocrit_min 28.10000 37.40000
hematocrit_max 28.10000 45.20000
potassium_min 5.50000 2.80000
potassium_max 5.50000 3.00000
sodium_min 138.00000 136.00000
sodium_max 138.00000 140.00000
bun_min 28.00000 16.00000
bun_max 28.00000 17.00000
wbc_min 2.50000 7.50000
wbc_max 2.50000 13.70000
mingcs 15.00000 15.00000
gcsmotor 6.00000 5.00000
gcsverbal 5.00000 0.00000
gcseyes 4.00000 1.00000
endotrachflag 0.00000 1.00000
urineoutput 1674.00000 887.00000
vasopressor 0.00000 0.00000
vent 0.00000 1.00000
los_hospital 19.09310 4.88130
los_icu 3.53680 5.32310
sofa 3.00000 5.00000
saps 17.00000 18.00000
posthospmort30day 1.00000 0.00000
Usually I wouldn't add a second answer, but that might be the best solution here. Don't worry about voting on it.
Here's the same algorithm as in my first answer, applied to the iris data set. Each row contains four spatial measurements of the flowers form three different varieties of iris plants.
Below that you will find the iris analysis, written out as nested loops so you can see the equivalence. But that's not recommended for production with large data sets.
Please familiarize yourself with starting data and all of the intermediate dataframes:
The input iris data
psm_scaled (the spatial measurements, scaled to mean=0, SD=1)
cs (the matrix of pairwise similarities)
cs.melt (the pairwise similarities in long format)
At the end I have aggregated the mean similarities for all comparisons between one variety and another. You will see that comparisons between individuals of the same variety have mean similarities approaching 1, and comparisons between individuals of the same variety have mean similarities approaching negative 1.
library(lsa)
library(reshape2)
temp <- iris[, 1:4]
iris.names <- paste0(iris$Species, '.', rownames(iris))
psm_scaled <- scale(temp)
rownames(psm_scaled) <- iris.names
cs <- lsa::cosine(t(psm_scaled))
# this is super inefficient, because cs contains
# two identical triangular matrices
cs.melt <- melt(cs)
cs.melt <- as.data.frame(cs.melt)
names(cs.melt) <- c("enc.A", "enc.B", "similarity")
names(cs.melt) <- c("flower.A", "flower.B", "similarity")
class.A <-
strsplit(as.character(cs.melt$flower.A), '.', fixed = TRUE)
cs.melt$class.A <- sapply(class.A, function(one.split) {
return(one.split[1])
})
class.B <-
strsplit(as.character(cs.melt$flower.B), '.', fixed = TRUE)
cs.melt$class.B <- sapply(class.B, function(one.split) {
return(one.split[1])
})
cs.melt$comparison <-
paste0(cs.melt$class.A , '_vs_', cs.melt$class.B)
cs.agg <-
aggregate(cs.melt$similarity, by = list(cs.melt$comparison), mean)
print(cs.agg[order(cs.agg$x),])
which gives
# Group.1 x
# 3 setosa_vs_virginica -0.7945321
# 7 virginica_vs_setosa -0.7945321
# 2 setosa_vs_versicolor -0.4868352
# 4 versicolor_vs_setosa -0.4868352
# 6 versicolor_vs_virginica 0.3774612
# 8 virginica_vs_versicolor 0.3774612
# 5 versicolor_vs_versicolor 0.4134413
# 9 virginica_vs_virginica 0.7622797
# 1 setosa_vs_setosa 0.8698189
If you’re still not comfortable with performing lsa::cosine() on a scaled, numerical dataframe, we can certainly do explicit pairwise calculations.
The formula you gave for PSM, or cosine similarity of patients, is expressed in two formats at Wikipedia
Remembering that vectors A and B represent the ordered list of attributes for PatientA and PatientB, the PSM is the dot product of A and B, divided by (the scalar product of [the magnitude of A] and [the magnitude of B])
The terse way of saying that in R is
cosine.sim <- function(A, B) { A %*% B / sqrt(A %*% A * B %*% B) }
But we can rewrite that to look more similar to your post as
cosine.sim <- function(A, B) { A %*% B / (sqrt(A %*% A) * sqrt(B %*% B)) }
I guess you could even re-write that (the calculations of similarity between a single pair of individuals) as a bunch of nested loops, but in the case of a manageable amount of data, please don’t. R is highly optimized for operations on vectors and matrices. If you’re new to R, don’t second guess it. By the way, what happened to your millions of rows? This will certainly be less stressful now that your down to tens of thousands.
Anyway, let’s say that each individual only has two elements.
individual.1 <- c(1, 0)
individual.2 <- c(1, 1)
So you can think of individual.1 as a line that passes between the origin (0,0) and (0, 1) and individual.2 as a line that passes between the origin and (1, 1).
some.data <- rbind.data.frame(individual.1, individual.2)
names(some.data) <- c('element.i', 'element.j')
rownames(some.data) <- c('individual.1', 'individual.2')
plot(some.data, xlim = c(-0.5, 2), ylim = c(-0.5, 2))
text(
some.data,
rownames(some.data),
xlim = c(-0.5, 2),
ylim = c(-0.5, 2),
adj = c(0, 0)
)
segments(0, 0, x1 = some.data[1, 1], y1 = some.data[1, 2])
segments(0, 0, x1 = some.data[2, 1], y1 = some.data[2, 2])
So what’s the angle between vector individual.1 and vector individual.2? You guessed it, 0.785 radians, or 45 degrees.
cosine.sim <- function(A, B) { A %*% B / (sqrt(A %*% A) * sqrt(B %*% B)) }
cos.sim.result <- cosine.sim(individual.1, individual.2)
angle.radians <- acos(cos.sim.result)
angle.degrees <- angle.radians * 180 / pi
print(angle.degrees)
# [,1]
# [1,] 45
Now we can use the cosine.sim function I previously defined, in two nested loops, to explicitly calculate the pairwise similarities between each of the iris flowers. Remember, psm_scaled has already been defined as the scaled numerical values from the iris dataset.
cs.melt <- lapply(rownames(psm_scaled), function(name.A) {
inner.loop.result <-
lapply(rownames(psm_scaled), function(name.B) {
individual.A <- psm_scaled[rownames(psm_scaled) == name.A, ]
individual.B <- psm_scaled[rownames(psm_scaled) == name.B, ]
similarity <- cosine.sim(individual.A, individual.B)
return(list(name.A, name.B, similarity))
})
inner.loop.result <-
do.call(rbind.data.frame, inner.loop.result)
names(inner.loop.result) <-
c('flower.A', 'flower.B', 'similarity')
return(inner.loop.result)
})
cs.melt <- do.call(rbind.data.frame, cs.melt)
Now we repeat the calculation of cs.melt$class.A, cs.melt$class.B, and cs.melt$comparison as above, and calculate cs.agg.from.loops as the mean similarity between the various types of comparisons:
cs.agg.from.loops <-
aggregate(cs.agg.from.loops$similarity, by = list(cs.agg.from.loops $comparison), mean)
print(cs.agg.from.loops[order(cs.agg.from.loops$x),])
# Group.1 x
# 3 setosa_vs_virginica -0.7945321
# 7 virginica_vs_setosa -0.7945321
# 2 setosa_vs_versicolor -0.4868352
# 4 versicolor_vs_setosa -0.4868352
# 6 versicolor_vs_virginica 0.3774612
# 8 virginica_vs_versicolor 0.3774612
# 5 versicolor_vs_versicolor 0.4134413
# 9 virginica_vs_virginica 0.7622797
# 1 setosa_vs_setosa 0.8698189
Which, I believe is identical to the result we got with lsa::cosine.
So what I'm trying to say is... why wouldn't you use lsa::cosine?
Maybe you should be more concerned with
selection of variables, including removal of highly correlated variables
scaling/normalizing/standardizing the data
performance with a large input data set
identifying known similars and dissimilars for quality control
as previously addressed
Up until now i have sorted everything according to the value of my variable so for example if i have a row of n numbers I would have picked the numbers that lie between a and b. What i in fact need to do is find the %a and %b.
I have been using this:
a <- 05
b <- 0.4
colnames(data[,which(data > a & data < b)])
What i need is to split my row into deciles. So the highest 10% values, then the ones that lie between 10% - 20% and so on up until highest 90% -100%. Values must not overlap withing the deciles and my data does not divide by 10 exactly.
EDIT
I have the following chunk of my data:
dput(data)
structure(list(AN8068571086 = c(0.501692168, 0.197414678, 0.415273482,
0.3078506, 0.36441391, 0.492483978, 0.398119861, 0.501925374,
0.660172121, 0.379188187), BMG3223R1088 = c(0.402426587, 0.214836776,
0.328226835, 0.265325336, 0.25724501, 0.396151915, 0.377199761,
0.31474308, 0.484177362, 0.412847814), BMG4388N1065 = c(0.592822703,
0.308105268, 0.374769701, 0.563959456, 0.335778936, 0.455266056,
0.510205508, 0.384208097, 0.460911179, 0.408350205), BMG6359F1032 = c(0.41153064,
0.221527294, 0.37383843, 0.329890556, 0.356333922, 0.397373547,
0.387519253, 0.424925141, 0.578383479, 0.411399158), BMG7496G1033 = c(0.478470376,
0.222667989, 0.33437412, 0.352835697, 0.299427154, 0.573123951,
0.466177145, 0.447775951, 0.477199807, 0.514107898), BMG812761002 = c(0.317522103,
0.265366064, 0.397487594, 0.348840651, 0.428338929, 0.282390173,
0.571658903, 0.450001013, 0.864445892, 0.418532333), CA88157K1012 = c(0.512859762,
0.183395043, 0.36847587, 0.364320833, 0.41197194, 0.628829565,
0.357019295, 0.341567448, 0.536733877, 0.343791549), CH0044328745 = c(0.499076264,
0.203778437, 0.310663532, 0.288884148, 0.247539664, 0.293768434,
0.348647329, 0.171457967, 0.391893463, 0.520079294), CH0048265513 = c(0.392308285,
0.245092722, 0.406807313, 0.338218477, 0.337216158, 0.396477472,
0.444780447, 0.513073443, 0.5655301, 0.372365682), GB00B4VLR192 = c(0.371059427,
0.243691452, 0.382559417, 0.36669396, 0.331187524, 0.336644629,
0.386660867, 0.408767967, 0.570252986, 0.350705351)), .Names = c("AN8068571086",
"BMG3223R1088", "BMG4388N1065", "BMG6359F1032", "BMG7496G1033",
"BMG812761002", "CA88157K1012", "CH0044328745", "CH0048265513",
"GB00B4VLR192"), row.names = c(NA, -10L), class = "data.frame")
The process should work as follows: (1) loop across rows , (2) find lowest 10% values, (3) get colnames of the columns where the 10% lowest values are, and store in a list. The code bellow is what i had before and searches for column names which have a row value that lies between a and b. all that i need is the column names and not the actual values from the row.
stockpicks <- list()
a <- 0.3
b <- 0.7
for (i in 1:nrow(data)) {
input <- as.matrix(data[1,])
#extract colnames of values between a and b
efficient <- matrix(colnames(data[,which(input > a & input < b)]))
# make a vector with new name for the output
tmp_date <- head(rownames(input), n=1)
#rename column
colnames(efficient) <-tmp_date
#export to list under new name
stockpicks[[tmp_date]] <- efficient
}
To expand on Eric's comment, you could use quantile with cut. For example given a vector of data, or a row of a matrix v you could do something like
v = rnorm(1000)
cut(v,breaks = quantile(v,probs = (0:10)/10))
which will give you a factor with 10 levels based on the deciles as break points.
Edit
Based on the updated question you could do something like the following:
d = as.matrix(data)
lapply(1:nrow(d), function(i) colnames(d)[d[i,] < quantile(d[i,],.1)])
You could also use apply on d directly with MARGIN = 1 but this would cause a problem if there was a differing number of values in the bottom 10% in different rows. It works on your minimal example but may not give the expected answer on a larger data frame.
Here is how you can use quantile to get what you want:
set.seed(0)
x <- as.integer(rnorm(1000, 100, 50))
quantile(x, probs = seq(0, 1, .1))
Output will be:
0% 10% 20% 30% 40% 50% 60% 70% 80% 90% 100%
-61.0 35.0 54.0 71.7 85.0 96.5 109.0 126.0 142.2 164.0 263.0