jeudi 16 novembre 2017

Conditional fitting in grouped data

Sorry for too long question but I'll try to be clear as possible about the problem.

I am trying to fit some data groups and getting fitting coefficients for each group.

similar questions can be found here but they are not related to fit in groups

Conditional nls

Trying to fit data with R and nls on a function with a condition in it

But it seems that the fitting doesn't seem to care the conditional setting so I am getting the same fitting coeffs for different groups.(This is also the same case for my real data.)

basically, what try to do is use different set of fitting coefficients if gr==a fit that group else fit gr==b.

I am using nlsLM from minpack.lm package since I also need to set the starting values for fitting coefs.

Here is the code which I have tried:

library(minpack.lm)

set.seed(95)

df <- data.frame(gr=rep(seq(1,2),each=10),sub_gr=rep(rep(c("a","b"),each=5),2),
              y = rep(c(sort(runif(5,0,0.5),decreasing=TRUE), sort(runif(5,0,0.5),,decreasing=TRUE)),2),
              x = rep(c(seq(0.1,0.5,0.1)),4))

#creating empty list to fill with fitting coefficients afterwards based on @Hack-R solution Error: Results are not data frames at positions:

empty_dat <- structure(list(x = numeric(0), y = numeric(0), gr = integer(0), sub_gr = character(0), 
              pred_fit = numeric(0), k_a = numeric(0), k_b = numeric(0),
              t_a = numeric(0), t_b= numeric(0)), class = "data.frame")

#do the fitting in groups


for(x in unique(df$gr)){

  #trycatch to   

  fit <- tryCatch(nlsLM(y~ifelse(sub_gr=='a', k_a*x+t_a, k_b/x+t_b),
                        data=df[df$gr==x,],start=c(k_a=0.3,k_b=0.4,t_a=0.1,t_b=0.2),

                        lower = c(0.05, 0.05, 0,0),
                        upper = c(1,1,1,1),                 
                        trace=T,na.action=na.omit, control = nls.lm.control(maxiter=100)),error=function(e) NULL)

  if(!("NULL" %in% class(fit))){
    pred_fit <- predict(fit, newdata =new.range)

    coefs_fit <- data.frame(k_a=coef(fit)[1],k_b=coef(fit)[2],t_a=coef(fit)[3], t_b=coef(fit)[4])



#filling empty_data with coefs and df's original values
        empty_dat <- rbind(empty_dat,data.frame(df[df$gr==x,],coefs_fit,pred_fit,row.names=NULL))
              }   
            }

empty_dat

  gr sub_gr          y   x  k_a  k_b       t_a       t_b  pred_fit
1   1      a 0.28792044 0.1 0.05 0.05 0.1343742 0.2156747 0.1393742
2   1      a 0.24443957 0.2 0.05 0.05 0.1343742 0.2156747 0.1443742
3   1      a 0.07585577 0.3 0.05 0.05 0.1343742 0.2156747 0.1493742
4   1      a 0.03522243 0.4 0.05 0.05 0.1343742 0.2156747 0.1543742
5   1      a 0.02654922 0.5 0.05 0.05 0.1343742 0.2156747 0.1593742
6   1      b 0.48498563 0.1 0.05 0.05 0.1343742 0.2156747 0.2206747
7   1      b 0.18702842 0.2 0.05 0.05 0.1343742 0.2156747 0.2256747
8   1      b 0.15186749 0.3 0.05 0.05 0.1343742 0.2156747 0.2306747
9   1      b 0.15003048 0.4 0.05 0.05 0.1343742 0.2156747 0.2356747
10  1      b 0.07638354 0.5 0.05 0.05 0.1343742 0.2156747 0.2406747
11  2      a 0.28792044 0.1 0.05 0.05 0.1343742 0.2156747 0.1393742
12  2      a 0.24443957 0.2 0.05 0.05 0.1343742 0.2156747 0.1443742
13  2      a 0.07585577 0.3 0.05 0.05 0.1343742 0.2156747 0.1493742
14  2      a 0.03522243 0.4 0.05 0.05 0.1343742 0.2156747 0.1543742
15  2      a 0.02654922 0.5 0.05 0.05 0.1343742 0.2156747 0.1593742
16  2      b 0.48498563 0.1 0.05 0.05 0.1343742 0.2156747 0.2206747
17  2      b 0.18702842 0.2 0.05 0.05 0.1343742 0.2156747 0.2256747
18  2      b 0.15186749 0.3 0.05 0.05 0.1343742 0.2156747 0.2306747
19  2      b 0.15003048 0.4 0.05 0.05 0.1343742 0.2156747 0.2356747
20  2      b 0.07638354 0.5 0.05 0.05 0.1343742 0.2156747 0.2406747

as we can see clearly the coefficients k_a, k_b and t_a , t_b is identical for each gr and sub_gr.

If I want to plot the result and predicted values of fitting

fitting lines telling the different story:))

library(ggplot2)

ggplot(df, aes(x=x, y=y,col=sub_gr,shape=sub_gr)) + 
  geom_point(size=6,alpha=0.8,stroke=1.4)  +
  theme_bw()+
  facet_wrap(~gr,scales='free')+
  scale_color_manual(values=c("blue","red"))+
  geom_line(data=empty_dat,aes(x=x,y=pred_fit,group=sub_gr,col=sub_gr))

enter image description here

Aucun commentaire:

Enregistrer un commentaire